Commit | Line | Data |
---|---|---|
ed797193 | 1 | ;;; proto-stream.el --- negotiating TLS, STARTTLS and other connections |
a33a2868 | 2 | |
ed797193 G |
3 | ;; Copyright (C) 2010 Free Software Foundation, Inc. |
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 | ||
25 | ;; This library is meant to provide the glue between modules that want | |
26 | ;; to establish a network connection to a server for protocols such as | |
27 | ;; IMAP, NNTP, SMTP and POP3. | |
28 | ||
29 | ;; The main problem is that there's more than a couple of interfaces | |
30 | ;; towards doing this. You have normal, plain connections, which are | |
31 | ;; no trouble at all, but you also have TLS/SSL connections, and you | |
32 | ;; have STARTTLS. Negotiating this for each protocol can be rather | |
33 | ;; tedious, so this library provides a single entry point, and hides | |
34 | ;; much of the ugliness. | |
35 | ||
36 | ;; Usage example: | |
37 | ||
38 | ;; (open-protocol-stream | |
39 | ;; "*nnimap*" buffer address port | |
40 | ;; :type 'network | |
41 | ;; :capability-command "1 CAPABILITY\r\n" | |
42 | ;; :success " OK " | |
43 | ;; :starttls-function | |
44 | ;; (lambda (capabilities) | |
45 | ;; (if (not (string-match "STARTTLS" capabilities)) | |
46 | ;; nil | |
47 | ;; "1 STARTTLS\r\n"))) | |
48 | ||
49 | ;;; Code: | |
50 | ||
51 | (eval-when-compile | |
52 | (require 'cl)) | |
53 | (require 'tls) | |
54 | (require 'starttls) | |
55 | (require 'format-spec) | |
56 | ||
57 | (defcustom proto-stream-always-use-starttls (fboundp 'open-gnutls-stream) | |
58 | "If non-nil, always try to upgrade network connections with STARTTLS." | |
59 | :version "24.1" | |
60 | :type 'boolean | |
61 | :group 'comm) | |
62 | ||
63 | (declare-function gnutls-negotiate "gnutls" | |
64 | (proc type &optional priority-string trustfiles keyfiles)) | |
65 | ||
66 | ;;;###autoload | |
67 | (defun open-protocol-stream (name buffer host service &rest parameters) | |
68 | "Open a network stream to HOST, upgrading to STARTTLS if possible. | |
69 | The first four parameters have the same meaning as in | |
70 | `open-network-stream'. The function returns a list where the | |
71 | first element is the stream, the second element is the greeting | |
72 | the server replied with after connecting, and the third element | |
73 | is a string representing the capabilities of the server (if any). | |
74 | ||
75 | The PARAMETERS is a keyword list that can have the following | |
76 | values: | |
77 | ||
78 | :type -- either `network', `tls', `shell' or `starttls'. If | |
79 | omitted, the default is `network'. `network' will be | |
80 | opportunistically upgraded to STARTTLS if both the server and | |
81 | Emacs supports it. | |
82 | ||
83 | :end-of-command -- a regexp saying what the end of a command is. | |
84 | This defaults to \"\\n\". | |
85 | ||
86 | :success -- a regexp saying whether the STARTTLS command was | |
87 | successful or not. For instance, for NNTP this is \"^3\". | |
88 | ||
89 | :capability-command -- a string representing the command used to | |
90 | query server for capabilities. For instance, for IMAP this is | |
91 | \"1 CAPABILITY\\r\\n\". | |
92 | ||
93 | :starttls-function -- a function that takes one parameter, which | |
94 | is the response to the capaibility command. It should return nil | |
95 | if it turns out that the server doesn't support STARTTLS, or the | |
96 | command to switch on STARTTLS otherwise." | |
97 | (let ((type (or (cadr (memq :type parameters)) 'network))) | |
98 | (cond | |
99 | ((eq type 'starttls) | |
100 | (setq type 'network)) | |
101 | ((eq type 'ssl) | |
102 | (setq type 'tls))) | |
103 | (destructuring-bind (stream greeting capabilities) | |
104 | (funcall (intern (format "proto-stream-open-%s" type) obarray) | |
105 | name buffer host service parameters) | |
106 | (list (and stream | |
107 | (memq (process-status stream) | |
108 | '(open run)) | |
109 | stream) | |
110 | greeting capabilities)))) | |
111 | ||
112 | (defun proto-stream-open-network (name buffer host service parameters) | |
113 | (let* ((start (with-current-buffer buffer (point))) | |
114 | (stream (open-network-stream name buffer host service)) | |
115 | (capability-command (cadr (memq :capability-command parameters))) | |
116 | (eoc (proto-stream-eoc parameters)) | |
117 | (type (cadr (memq :type parameters))) | |
118 | (greeting (proto-stream-get-response stream start eoc)) | |
119 | success) | |
120 | (if (not capability-command) | |
121 | (list stream greeting nil) | |
122 | (let* ((capabilities | |
123 | (proto-stream-command stream capability-command eoc)) | |
124 | (starttls-command | |
125 | (funcall (cadr (memq :starttls-function parameters)) | |
126 | capabilities))) | |
127 | (cond | |
128 | ;; If this server doesn't support STARTTLS, but we have | |
129 | ;; requested it explicitly, then close the connection and | |
130 | ;; return nil. | |
131 | ((or (not starttls-command) | |
132 | (and (not (eq type 'starttls)) | |
133 | (not proto-stream-always-use-starttls))) | |
134 | (if (eq type 'starttls) | |
135 | (progn | |
136 | (delete-process stream) | |
137 | nil) | |
138 | ;; Otherwise, just return this plain network connection. | |
139 | (list stream greeting capabilities))) | |
140 | ;; We have some kind of STARTTLS support, so we try to | |
141 | ;; upgrade the connection opportunistically. | |
142 | ((or (fboundp 'open-gnutls-stream) | |
143 | (executable-find "gnutls-cli")) | |
144 | (unless (fboundp 'open-gnutls-stream) | |
145 | (delete-process stream) | |
146 | (setq start (with-current-buffer buffer (point-max))) | |
147 | (let* ((starttls-use-gnutls t) | |
148 | (starttls-extra-arguments | |
149 | (if (not (eq type 'starttls)) | |
150 | ;; When doing opportunistic TLS upgrades we | |
151 | ;; don't really care about the identity of the | |
152 | ;; peer. | |
153 | (cons "--insecure" starttls-extra-arguments) | |
154 | starttls-extra-arguments))) | |
155 | (setq stream (starttls-open-stream name buffer host service))) | |
156 | (proto-stream-get-response stream start eoc)) | |
157 | (if (not | |
158 | (string-match | |
159 | (cadr (memq :success parameters)) | |
160 | (proto-stream-command stream starttls-command eoc))) | |
161 | ;; We got an error back from the STARTTLS command. | |
162 | (progn | |
163 | (if (eq type 'starttls) | |
164 | (progn | |
165 | (delete-process stream) | |
166 | nil) | |
167 | (list stream greeting capabilities))) | |
168 | ;; The server said it was OK to start doing STARTTLS negotiations. | |
169 | (if (fboundp 'open-gnutls-stream) | |
170 | (gnutls-negotiate stream nil) | |
171 | (unless (starttls-negotiate stream) | |
172 | (delete-process stream) | |
173 | (setq stream nil))) | |
174 | (when (or (null stream) | |
175 | (not (memq (process-status stream) | |
176 | '(open run)))) | |
177 | ;; It didn't successfully negotiate STARTTLS, so we reopen | |
178 | ;; the connection. | |
179 | (setq stream (open-network-stream name buffer host service)) | |
180 | (proto-stream-get-response stream start eoc)) | |
181 | ;; Re-get the capabilities, since they may have changed | |
182 | ;; after switching to TLS. | |
183 | (list stream greeting | |
184 | (proto-stream-command stream capability-command eoc)))) | |
185 | ;; We don't have STARTTLS support available, but the caller | |
186 | ;; requested a STARTTLS connection, so we give up. | |
187 | ((eq (cadr (memq :type parameters)) 'starttls) | |
188 | (delete-process stream) | |
189 | nil) | |
190 | ;; Fall back on using a plain network stream. | |
191 | (t | |
192 | (list stream greeting capabilities))))))) | |
193 | ||
194 | (defun proto-stream-command (stream command eoc) | |
195 | (let ((start (with-current-buffer (process-buffer stream) (point-max)))) | |
196 | (process-send-string stream command) | |
197 | (proto-stream-get-response stream start eoc))) | |
198 | ||
199 | (defun proto-stream-get-response (stream start end-of-command) | |
200 | (with-current-buffer (process-buffer stream) | |
201 | (save-excursion | |
202 | (goto-char start) | |
203 | (while (and (memq (process-status stream) | |
204 | '(open run)) | |
205 | (not (re-search-forward end-of-command nil t))) | |
206 | (accept-process-output stream 0 50) | |
207 | (goto-char start)) | |
208 | (if (= start (point)) | |
209 | ;; The process died; return nil. | |
210 | nil | |
211 | ;; Return the data we got back. | |
212 | (buffer-substring start (point)))))) | |
213 | ||
214 | (defun proto-stream-open-tls (name buffer host service parameters) | |
215 | (with-current-buffer buffer | |
216 | (let ((start (point-max)) | |
217 | (stream | |
218 | (funcall (if (fboundp 'open-gnutls-stream) | |
219 | 'open-gnutls-stream | |
220 | 'open-tls-stream) | |
221 | name buffer host service))) | |
222 | ;; If we're using tls.el, we have to delete the output from | |
223 | ;; openssl/gnutls-cli. | |
224 | (unless (fboundp 'open-gnutls-stream) | |
225 | (proto-stream-get-response | |
226 | stream start (proto-stream-eoc parameters)) | |
227 | (goto-char (point-min)) | |
228 | (when (re-search-forward (proto-stream-eoc parameters) nil t) | |
229 | (goto-char (match-beginning 0)) | |
230 | (delete-region (point-min) (line-beginning-position)))) | |
231 | (proto-stream-capability-open start stream parameters)))) | |
232 | ||
233 | (defun proto-stream-open-shell (name buffer host service parameters) | |
234 | (proto-stream-capability-open | |
235 | (with-current-buffer buffer (point)) | |
236 | (let ((process-connection-type nil)) | |
237 | (start-process name buffer shell-file-name | |
238 | shell-command-switch | |
239 | (format-spec | |
240 | (cadr (memq :shell-command parameters)) | |
241 | (format-spec-make | |
242 | ?s host | |
243 | ?p service)))) | |
244 | parameters)) | |
245 | ||
246 | (defun proto-stream-capability-open (start stream parameters) | |
247 | (let ((capability-command (cadr (memq :capability-command parameters))) | |
248 | (greeting (proto-stream-get-response | |
249 | stream start (proto-stream-eoc parameters)))) | |
250 | (list stream greeting | |
251 | (and capability-command | |
252 | (proto-stream-command | |
253 | stream capability-command (proto-stream-eoc parameters)))))) | |
254 | ||
255 | (defun proto-stream-eoc (parameters) | |
256 | (or (cadr (memq :end-of-command parameters)) | |
257 | "\r\n")) | |
258 | ||
259 | (provide 'proto-stream) | |
260 | ||
261 | ;;; proto-stream.el ends here |