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