Mercurial > emacs
annotate src/gnutls.c @ 110648:256dd50b2a63
Make sure all reads/writes to gnutls streams go via the gnutls functions.
author | Lars Magne Ingebrigtsen <larsi@gnus.org> |
---|---|
date | Wed, 29 Sep 2010 14:48:29 +0200 |
parents | 31e098898561 |
children | 2f0d755fa21b |
rev | line source |
---|---|
110584 | 1 /* GnuTLS glue for GNU Emacs. |
2 Copyright (C) 2010 Free Software Foundation, Inc. | |
3 | |
4 This file is part of GNU Emacs. | |
5 | |
6 GNU Emacs is free software: you can redistribute it and/or modify | |
7 it under the terms of the GNU General Public License as published by | |
8 the Free Software Foundation, either version 3 of the License, or | |
9 (at your option) any later version. | |
10 | |
11 GNU Emacs is distributed in the hope that it will be useful, | |
12 but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 GNU General Public License for more details. | |
15 | |
16 You should have received a copy of the GNU General Public License | |
17 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ | |
18 | |
19 #include <config.h> | |
20 #include <errno.h> | |
21 #include <setjmp.h> | |
22 | |
23 #include "lisp.h" | |
24 #include "process.h" | |
25 | |
26 #ifdef HAVE_GNUTLS | |
27 #include <gnutls/gnutls.h> | |
28 | |
29 Lisp_Object Qgnutls_code; | |
30 Lisp_Object Qgnutls_anon, Qgnutls_x509pki; | |
31 Lisp_Object Qgnutls_e_interrupted, Qgnutls_e_again, | |
32 Qgnutls_e_invalid_session, Qgnutls_e_not_ready_for_handshake; | |
33 int global_initialized; | |
34 | |
35 int | |
110648
256dd50b2a63
Make sure all reads/writes to gnutls streams go via the gnutls functions.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110636
diff
changeset
|
36 emacs_gnutls_write (int fildes, struct Lisp_Process *proc, char *buf, |
110584 | 37 unsigned int nbyte) |
38 { | |
39 register int rtnval, bytes_written; | |
110648
256dd50b2a63
Make sure all reads/writes to gnutls streams go via the gnutls functions.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110636
diff
changeset
|
40 gnutls_session_t state = proc->gnutls_state; |
256dd50b2a63
Make sure all reads/writes to gnutls streams go via the gnutls functions.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110636
diff
changeset
|
41 |
256dd50b2a63
Make sure all reads/writes to gnutls streams go via the gnutls functions.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110636
diff
changeset
|
42 if (proc->gnutls_initstage != GNUTLS_STAGE_READY) |
256dd50b2a63
Make sure all reads/writes to gnutls streams go via the gnutls functions.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110636
diff
changeset
|
43 return 0; |
110584 | 44 |
45 bytes_written = 0; | |
46 | |
47 while (nbyte > 0) | |
48 { | |
49 rtnval = gnutls_write (state, buf, nbyte); | |
50 | |
51 if (rtnval == -1) | |
52 { | |
53 if (errno == EINTR) | |
54 continue; | |
55 else | |
56 return (bytes_written ? bytes_written : -1); | |
57 } | |
58 | |
59 buf += rtnval; | |
60 nbyte -= rtnval; | |
61 bytes_written += rtnval; | |
62 } | |
63 fsync (STDOUT_FILENO); | |
64 | |
65 return (bytes_written); | |
66 } | |
67 | |
68 int | |
110648
256dd50b2a63
Make sure all reads/writes to gnutls streams go via the gnutls functions.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110636
diff
changeset
|
69 emacs_gnutls_read (int fildes, struct Lisp_Process *proc, char *buf, |
110584 | 70 unsigned int nbyte) |
71 { | |
72 register int rtnval; | |
110648
256dd50b2a63
Make sure all reads/writes to gnutls streams go via the gnutls functions.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110636
diff
changeset
|
73 gnutls_session_t state = proc->gnutls_state; |
256dd50b2a63
Make sure all reads/writes to gnutls streams go via the gnutls functions.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110636
diff
changeset
|
74 |
256dd50b2a63
Make sure all reads/writes to gnutls streams go via the gnutls functions.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110636
diff
changeset
|
75 if (proc->gnutls_initstage != GNUTLS_STAGE_READY) |
256dd50b2a63
Make sure all reads/writes to gnutls streams go via the gnutls functions.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110636
diff
changeset
|
76 return 0; |
110584 | 77 |
110608
06497cf3e920
(emacs_gnutls_read): Don't infloop while reading.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110606
diff
changeset
|
78 rtnval = gnutls_read (state, buf, nbyte); |
06497cf3e920
(emacs_gnutls_read): Don't infloop while reading.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110606
diff
changeset
|
79 if (rtnval >= 0) |
06497cf3e920
(emacs_gnutls_read): Don't infloop while reading.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110606
diff
changeset
|
80 return rtnval; |
06497cf3e920
(emacs_gnutls_read): Don't infloop while reading.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110606
diff
changeset
|
81 else |
110648
256dd50b2a63
Make sure all reads/writes to gnutls streams go via the gnutls functions.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110636
diff
changeset
|
82 return 0; |
110584 | 83 } |
84 | |
85 /* convert an integer error to a Lisp_Object; it will be either a | |
86 known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or | |
87 simply the integer value of the error. GNUTLS_E_SUCCESS is mapped | |
88 to Qt. */ | |
89 Lisp_Object gnutls_make_error (int error) | |
90 { | |
91 switch (error) | |
92 { | |
93 case GNUTLS_E_SUCCESS: | |
94 return Qt; | |
95 case GNUTLS_E_AGAIN: | |
96 return Qgnutls_e_again; | |
97 case GNUTLS_E_INTERRUPTED: | |
98 return Qgnutls_e_interrupted; | |
99 case GNUTLS_E_INVALID_SESSION: | |
100 return Qgnutls_e_invalid_session; | |
101 } | |
102 | |
103 return make_number (error); | |
104 } | |
105 | |
106 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage, Sgnutls_get_initstage, 1, 1, 0, | |
107 doc: /* Return the GnuTLS init stage of PROCESS. | |
108 See also `gnutls-boot'. */) | |
109 (Lisp_Object proc) | |
110 { | |
111 CHECK_PROCESS (proc); | |
112 | |
113 return make_number (GNUTLS_INITSTAGE (proc)); | |
114 } | |
115 | |
116 DEFUN ("gnutls-errorp", Fgnutls_errorp, Sgnutls_errorp, 1, 1, 0, | |
117 doc: /* Returns t if ERROR (as generated by gnutls_make_error) | |
118 indicates a GnuTLS problem. */) | |
119 (Lisp_Object error) | |
120 { | |
121 if (EQ (error, Qt)) return Qnil; | |
122 | |
123 return Qt; | |
124 } | |
125 | |
126 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp, Sgnutls_error_fatalp, 1, 1, 0, | |
127 doc: /* Checks if ERROR is fatal. | |
128 ERROR is an integer or a symbol with an integer `gnutls-code' property. */) | |
129 (Lisp_Object err) | |
130 { | |
131 Lisp_Object code; | |
132 | |
133 if (EQ (err, Qt)) return Qnil; | |
134 | |
135 if (SYMBOLP (err)) | |
136 { | |
137 code = Fget (err, Qgnutls_code); | |
138 if (NUMBERP (code)) | |
139 { | |
140 err = code; | |
141 } | |
142 else | |
143 { | |
144 error ("Symbol has no numeric gnutls-code property"); | |
145 } | |
146 } | |
147 | |
148 if (!NUMBERP (err)) | |
149 error ("Not an error symbol or code"); | |
150 | |
151 if (0 == gnutls_error_is_fatal (XINT (err))) | |
152 return Qnil; | |
153 | |
154 return Qt; | |
155 } | |
156 | |
157 DEFUN ("gnutls-error-string", Fgnutls_error_string, Sgnutls_error_string, 1, 1, 0, | |
158 doc: /* Returns a description of ERROR. | |
159 ERROR is an integer or a symbol with an integer `gnutls-code' property. */) | |
160 (Lisp_Object err) | |
161 { | |
162 Lisp_Object code; | |
163 | |
164 if (EQ (err, Qt)) return build_string ("Not an error"); | |
165 | |
166 if (SYMBOLP (err)) | |
167 { | |
168 code = Fget (err, Qgnutls_code); | |
169 if (NUMBERP (code)) | |
170 { | |
171 err = code; | |
172 } | |
173 else | |
174 { | |
175 return build_string ("Symbol has no numeric gnutls-code property"); | |
176 } | |
177 } | |
178 | |
179 if (!NUMBERP (err)) | |
180 return build_string ("Not an error symbol or code"); | |
181 | |
182 return build_string (gnutls_strerror (XINT (err))); | |
183 } | |
184 | |
185 DEFUN ("gnutls-deinit", Fgnutls_deinit, Sgnutls_deinit, 1, 1, 0, | |
186 doc: /* Deallocate GNU TLS resources associated with PROCESS. | |
187 See also `gnutls-init'. */) | |
188 (Lisp_Object proc) | |
189 { | |
190 gnutls_session_t state; | |
191 | |
192 CHECK_PROCESS (proc); | |
193 state = XPROCESS (proc)->gnutls_state; | |
194 | |
195 if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_INIT) | |
196 { | |
197 gnutls_deinit (state); | |
198 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT - 1; | |
199 } | |
200 | |
201 return Qt; | |
202 } | |
203 | |
204 /* Initializes global GNU TLS state to defaults. | |
205 Call `gnutls-global-deinit' when GNU TLS usage is no longer needed. | |
206 Returns zero on success. */ | |
207 Lisp_Object gnutls_emacs_global_init (void) | |
208 { | |
209 int ret = GNUTLS_E_SUCCESS; | |
210 | |
211 if (!global_initialized) | |
212 ret = gnutls_global_init (); | |
213 | |
214 global_initialized = 1; | |
215 | |
216 return gnutls_make_error (ret); | |
217 } | |
218 | |
219 /* Deinitializes global GNU TLS state. | |
220 See also `gnutls-global-init'. */ | |
221 Lisp_Object gnutls_emacs_global_deinit (void) | |
222 { | |
223 if (global_initialized) | |
224 gnutls_global_deinit (); | |
225 | |
226 global_initialized = 0; | |
227 | |
228 return gnutls_make_error (GNUTLS_E_SUCCESS); | |
229 } | |
230 | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
231 static void gnutls_log_function (int level, const char* string) |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
232 { |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
233 message("gnutls.c: [%d] %s", level, string); |
110606
b4f4c3e9b976
Add debugging to the gnutls library, and finish handshaking when it's done.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110584
diff
changeset
|
234 } |
b4f4c3e9b976
Add debugging to the gnutls library, and finish handshaking when it's done.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110584
diff
changeset
|
235 |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
236 DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 7, 0, |
110584 | 237 doc: /* Initializes client-mode GnuTLS for process PROC. |
238 Currently only client mode is supported. Returns a success/failure | |
239 value you can check with `gnutls-errorp'. | |
240 | |
241 PRIORITY_STRING is a string describing the priority. | |
242 TYPE is either `gnutls-anon' or `gnutls-x509pki'. | |
243 TRUSTFILE is a PEM encoded trust file for `gnutls-x509pki'. | |
244 KEYFILE is ... for `gnutls-x509pki' (TODO). | |
245 CALLBACK is ... for `gnutls-x509pki' (TODO). | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
246 LOGLEVEL is the debug level requested from GnuTLS, try 4. |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
247 |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
248 LOGLEVEL will be set for this process AND globally for GnuTLS. So if |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
249 you set it higher or lower at any point, it affects global debugging. |
110584 | 250 |
251 Note that the priority is set on the client. The server does not use | |
252 the protocols's priority except for disabling protocols that were not | |
253 specified. | |
254 | |
255 Processes must be initialized with this function before other GNU TLS | |
256 functions are used. This function allocates resources which can only | |
257 be deallocated by calling `gnutls-deinit' or by calling it again. | |
258 | |
259 Each authentication type may need additional information in order to | |
260 work. For X.509 PKI (`gnutls-x509pki'), you need TRUSTFILE and | |
261 KEYFILE and optionally CALLBACK. */) | |
262 (Lisp_Object proc, Lisp_Object priority_string, Lisp_Object type, | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
263 Lisp_Object trustfile, Lisp_Object keyfile, Lisp_Object callback, |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
264 Lisp_Object loglevel) |
110584 | 265 { |
266 int ret = GNUTLS_E_SUCCESS; | |
267 | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
268 int max_log_level = 0; |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
269 |
110584 | 270 /* TODO: GNUTLS_X509_FMT_DER is also an option. */ |
271 int file_format = GNUTLS_X509_FMT_PEM; | |
272 | |
273 gnutls_session_t state; | |
274 gnutls_certificate_credentials_t x509_cred; | |
275 gnutls_anon_client_credentials_t anon_cred; | |
276 Lisp_Object global_init; | |
277 | |
278 CHECK_PROCESS (proc); | |
279 CHECK_SYMBOL (type); | |
280 CHECK_STRING (priority_string); | |
281 | |
282 state = XPROCESS (proc)->gnutls_state; | |
110648
256dd50b2a63
Make sure all reads/writes to gnutls streams go via the gnutls functions.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110636
diff
changeset
|
283 XPROCESS (proc)->gnutls_p = 1; |
110584 | 284 |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
285 if (NUMBERP (loglevel)) |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
286 { |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
287 message ("setting up log level %d", XINT (loglevel)); |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
288 gnutls_global_set_log_function (gnutls_log_function); |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
289 gnutls_global_set_log_level (XINT (loglevel)); |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
290 max_log_level = XINT (loglevel); |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
291 XPROCESS (proc)->gnutls_log_level = max_log_level; |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
292 } |
110648
256dd50b2a63
Make sure all reads/writes to gnutls streams go via the gnutls functions.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110636
diff
changeset
|
293 |
110584 | 294 /* always initialize globals. */ |
295 global_init = gnutls_emacs_global_init (); | |
296 if (! NILP (Fgnutls_errorp (global_init))) | |
297 return global_init; | |
298 | |
299 /* deinit and free resources. */ | |
300 if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_CRED_ALLOC) | |
301 { | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
302 GNUTLS_LOG (1, max_log_level, "deallocating credentials"); |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
303 |
110584 | 304 if (EQ (type, Qgnutls_x509pki)) |
305 { | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
306 GNUTLS_LOG (2, max_log_level, "deallocating x509 credentials"); |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
307 x509_cred = XPROCESS (proc)->gnutls_x509_cred; |
110584 | 308 gnutls_certificate_free_credentials (x509_cred); |
309 } | |
310 else if (EQ (type, Qgnutls_anon)) | |
311 { | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
312 GNUTLS_LOG (2, max_log_level, "deallocating anon credentials"); |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
313 anon_cred = XPROCESS (proc)->gnutls_anon_cred; |
110584 | 314 gnutls_anon_free_client_credentials (anon_cred); |
315 } | |
316 else | |
317 { | |
318 error ("unknown credential type"); | |
319 ret = GNUTLS_EMACS_ERROR_INVALID_TYPE; | |
320 } | |
321 | |
322 if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_INIT) | |
323 { | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
324 GNUTLS_LOG (1, max_log_level, "deallocating x509 credentials"); |
110584 | 325 Fgnutls_deinit (proc); |
326 } | |
327 } | |
328 | |
329 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_EMPTY; | |
330 | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
331 GNUTLS_LOG (1, max_log_level, "allocating credentials"); |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
332 |
110584 | 333 if (EQ (type, Qgnutls_x509pki)) |
334 { | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
335 GNUTLS_LOG (2, max_log_level, "allocating x509 credentials"); |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
336 x509_cred = XPROCESS (proc)->gnutls_x509_cred; |
110584 | 337 if (gnutls_certificate_allocate_credentials (&x509_cred) < 0) |
338 memory_full (); | |
339 } | |
340 else if (EQ (type, Qgnutls_anon)) | |
341 { | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
342 GNUTLS_LOG (2, max_log_level, "allocating anon credentials"); |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
343 anon_cred = XPROCESS (proc)->gnutls_anon_cred; |
110584 | 344 if (gnutls_anon_allocate_client_credentials (&anon_cred) < 0) |
345 memory_full (); | |
346 } | |
347 else | |
348 { | |
349 error ("unknown credential type"); | |
350 ret = GNUTLS_EMACS_ERROR_INVALID_TYPE; | |
351 } | |
352 | |
353 if (ret < GNUTLS_E_SUCCESS) | |
354 return gnutls_make_error (ret); | |
355 | |
356 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_ALLOC; | |
357 | |
358 if (EQ (type, Qgnutls_x509pki)) | |
359 { | |
360 if (STRINGP (trustfile)) | |
361 { | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
362 GNUTLS_LOG (1, max_log_level, "setting the trustfile"); |
110584 | 363 ret = gnutls_certificate_set_x509_trust_file |
364 (x509_cred, | |
110636
31e098898561
* src/gnutls.c (Fgnutls_boot): Remove unused vars `data' and `srp_cred'.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
110611
diff
changeset
|
365 SDATA (trustfile), |
110584 | 366 file_format); |
367 | |
368 if (ret < GNUTLS_E_SUCCESS) | |
369 return gnutls_make_error (ret); | |
370 } | |
371 | |
372 if (STRINGP (keyfile)) | |
373 { | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
374 GNUTLS_LOG (1, max_log_level, "setting the keyfile"); |
110584 | 375 ret = gnutls_certificate_set_x509_crl_file |
376 (x509_cred, | |
110636
31e098898561
* src/gnutls.c (Fgnutls_boot): Remove unused vars `data' and `srp_cred'.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
110611
diff
changeset
|
377 SDATA (keyfile), |
110584 | 378 file_format); |
379 | |
380 if (ret < GNUTLS_E_SUCCESS) | |
381 return gnutls_make_error (ret); | |
382 } | |
383 } | |
384 | |
385 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_FILES; | |
386 | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
387 GNUTLS_LOG (1, max_log_level, "gnutls_init"); |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
388 |
110584 | 389 ret = gnutls_init (&state, GNUTLS_CLIENT); |
390 | |
391 if (ret < GNUTLS_E_SUCCESS) | |
392 return gnutls_make_error (ret); | |
393 | |
394 XPROCESS (proc)->gnutls_state = state; | |
395 | |
396 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT; | |
397 | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
398 GNUTLS_LOG (1, max_log_level, "setting the priority string"); |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
399 |
110584 | 400 ret = gnutls_priority_set_direct(state, |
401 (char*) SDATA (priority_string), | |
402 NULL); | |
403 | |
404 if (ret < GNUTLS_E_SUCCESS) | |
405 return gnutls_make_error (ret); | |
406 | |
407 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_PRIORITY; | |
408 | |
409 message ("gnutls: setting the credentials"); | |
410 | |
411 if (EQ (type, Qgnutls_x509pki)) | |
412 { | |
413 message ("gnutls: setting the x509 credentials"); | |
414 | |
415 ret = gnutls_cred_set (state, GNUTLS_CRD_CERTIFICATE, x509_cred); | |
416 } | |
417 else if (EQ (type, Qgnutls_anon)) | |
418 { | |
419 message ("gnutls: setting the anon credentials"); | |
420 | |
421 ret = gnutls_cred_set (state, GNUTLS_CRD_ANON, anon_cred); | |
422 } | |
423 else | |
424 { | |
425 error ("unknown credential type"); | |
426 ret = GNUTLS_EMACS_ERROR_INVALID_TYPE; | |
427 } | |
428 | |
429 if (ret < GNUTLS_E_SUCCESS) | |
430 return gnutls_make_error (ret); | |
431 | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
432 XPROCESS (proc)->gnutls_anon_cred = anon_cred; |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
433 XPROCESS (proc)->gnutls_x509_cred = x509_cred; |
110584 | 434 XPROCESS (proc)->gnutls_cred_type = type; |
435 | |
436 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET; | |
437 | |
438 return gnutls_make_error (GNUTLS_E_SUCCESS); | |
439 } | |
440 | |
441 DEFUN ("gnutls-bye", Fgnutls_bye, | |
442 Sgnutls_bye, 2, 2, 0, | |
443 doc: /* Terminate current GNU TLS connection for PROCESS. | |
444 The connection should have been initiated using `gnutls-handshake'. | |
445 | |
446 If CONT is not nil the TLS connection gets terminated and further | |
447 receives and sends will be disallowed. If the return value is zero you | |
448 may continue using the connection. If CONT is nil, GnuTLS actually | |
449 sends an alert containing a close request and waits for the peer to | |
450 reply with the same message. In order to reuse the connection you | |
451 should wait for an EOF from the peer. | |
452 | |
453 This function may also return `gnutls-e-again', or | |
454 `gnutls-e-interrupted'. */) | |
455 (Lisp_Object proc, Lisp_Object cont) | |
456 { | |
457 gnutls_session_t state; | |
458 int ret; | |
459 | |
460 CHECK_PROCESS (proc); | |
461 | |
462 state = XPROCESS (proc)->gnutls_state; | |
463 | |
464 ret = gnutls_bye (state, | |
465 NILP (cont) ? GNUTLS_SHUT_RDWR : GNUTLS_SHUT_WR); | |
466 | |
467 return gnutls_make_error (ret); | |
468 } | |
469 | |
470 DEFUN ("gnutls-handshake", Fgnutls_handshake, | |
471 Sgnutls_handshake, 1, 1, 0, | |
472 doc: /* Perform GNU TLS handshake for PROCESS. | |
473 The identity of the peer is checked automatically. This function will | |
474 fail if any problem is encountered, and will return a negative error | |
475 code. In case of a client, if it has been asked to resume a session, | |
476 but the server didn't, then a full handshake will be performed. | |
477 | |
478 If the error `gnutls-e-not-ready-for-handshake' is returned, you | |
479 didn't call `gnutls-boot' first. | |
480 | |
481 This function may also return the non-fatal errors `gnutls-e-again', | |
482 or `gnutls-e-interrupted'. In that case you may resume the handshake | |
483 (by calling this function again). */) | |
484 (Lisp_Object proc) | |
485 { | |
486 gnutls_session_t state; | |
487 int ret; | |
488 | |
489 CHECK_PROCESS (proc); | |
490 state = XPROCESS (proc)->gnutls_state; | |
491 | |
492 if (GNUTLS_INITSTAGE (proc) < GNUTLS_STAGE_HANDSHAKE_CANDO) | |
493 return Qgnutls_e_not_ready_for_handshake; | |
494 | |
110648
256dd50b2a63
Make sure all reads/writes to gnutls streams go via the gnutls functions.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110636
diff
changeset
|
495 |
110584 | 496 if (GNUTLS_INITSTAGE (proc) < GNUTLS_STAGE_TRANSPORT_POINTERS_SET) |
497 { | |
498 /* for a network process in Emacs infd and outfd are the same | |
499 but this shows our intent more clearly. */ | |
500 message ("gnutls: handshake: setting the transport pointers to %d/%d", | |
501 XPROCESS (proc)->infd, XPROCESS (proc)->outfd); | |
502 | |
110636
31e098898561
* src/gnutls.c (Fgnutls_boot): Remove unused vars `data' and `srp_cred'.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
110611
diff
changeset
|
503 /* FIXME: This can't be right: infd and outfd are integers (file handles) |
31e098898561
* src/gnutls.c (Fgnutls_boot): Remove unused vars `data' and `srp_cred'.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
110611
diff
changeset
|
504 whereas the function expects args of type gnutls_transport_ptr_t. */ |
110584 | 505 gnutls_transport_set_ptr2 (state, XPROCESS (proc)->infd, |
506 XPROCESS (proc)->outfd); | |
507 | |
508 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_TRANSPORT_POINTERS_SET; | |
509 } | |
510 | |
511 ret = gnutls_handshake (state); | |
512 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_HANDSHAKE_TRIED; | |
513 | |
110648
256dd50b2a63
Make sure all reads/writes to gnutls streams go via the gnutls functions.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110636
diff
changeset
|
514 if (ret == GNUTLS_E_SUCCESS) |
110584 | 515 { |
516 /* here we're finally done. */ | |
517 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_READY; | |
518 } | |
519 | |
520 return gnutls_make_error (ret); | |
521 } | |
522 | |
523 void | |
524 syms_of_gnutls (void) | |
525 { | |
526 global_initialized = 0; | |
527 | |
528 Qgnutls_code = intern_c_string ("gnutls-code"); | |
529 staticpro (&Qgnutls_code); | |
530 | |
531 Qgnutls_anon = intern_c_string ("gnutls-anon"); | |
532 staticpro (&Qgnutls_anon); | |
533 | |
534 Qgnutls_x509pki = intern_c_string ("gnutls-x509pki"); | |
535 staticpro (&Qgnutls_x509pki); | |
536 | |
537 Qgnutls_e_interrupted = intern_c_string ("gnutls-e-interrupted"); | |
538 staticpro (&Qgnutls_e_interrupted); | |
539 Fput (Qgnutls_e_interrupted, Qgnutls_code, | |
540 make_number (GNUTLS_E_INTERRUPTED)); | |
541 | |
542 Qgnutls_e_again = intern_c_string ("gnutls-e-again"); | |
543 staticpro (&Qgnutls_e_again); | |
544 Fput (Qgnutls_e_again, Qgnutls_code, | |
545 make_number (GNUTLS_E_AGAIN)); | |
546 | |
547 Qgnutls_e_invalid_session = intern_c_string ("gnutls-e-invalid-session"); | |
548 staticpro (&Qgnutls_e_invalid_session); | |
549 Fput (Qgnutls_e_invalid_session, Qgnutls_code, | |
550 make_number (GNUTLS_E_INVALID_SESSION)); | |
551 | |
552 Qgnutls_e_not_ready_for_handshake = | |
553 intern_c_string ("gnutls-e-not-ready-for-handshake"); | |
554 staticpro (&Qgnutls_e_not_ready_for_handshake); | |
555 Fput (Qgnutls_e_not_ready_for_handshake, Qgnutls_code, | |
556 make_number (GNUTLS_E_APPLICATION_ERROR_MIN)); | |
557 | |
558 defsubr (&Sgnutls_get_initstage); | |
559 defsubr (&Sgnutls_errorp); | |
560 defsubr (&Sgnutls_error_fatalp); | |
561 defsubr (&Sgnutls_error_string); | |
562 defsubr (&Sgnutls_boot); | |
563 defsubr (&Sgnutls_deinit); | |
564 defsubr (&Sgnutls_handshake); | |
565 defsubr (&Sgnutls_bye); | |
566 } | |
567 #endif |