Merge changes made in Gnus trunk.
[emacs.git] / src / gnutls.c
blob1cc258a50962fc4ee25f6bac4f6079c7a91d465f
1 /* GnuTLS glue for GNU Emacs.
2 Copyright (C) 2010 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
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.
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.
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/>. */
19 #include <config.h>
20 #include <errno.h>
21 #include <setjmp.h>
23 #include "lisp.h"
24 #include "process.h"
26 #ifdef HAVE_GNUTLS
27 #include <gnutls/gnutls.h>
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;
35 /* The following are for the property list of `gnutls-boot'. */
36 Lisp_Object Qgnutls_bootprop_priority;
37 Lisp_Object Qgnutls_bootprop_trustfiles;
38 Lisp_Object Qgnutls_bootprop_keyfiles;
39 Lisp_Object Qgnutls_bootprop_callbacks;
40 Lisp_Object Qgnutls_bootprop_loglevel;
42 static void
43 emacs_gnutls_handshake (struct Lisp_Process *proc)
45 gnutls_session_t state = proc->gnutls_state;
46 int ret;
48 if (proc->gnutls_initstage < GNUTLS_STAGE_HANDSHAKE_CANDO)
49 return;
51 if (proc->gnutls_initstage < GNUTLS_STAGE_TRANSPORT_POINTERS_SET)
53 /* This is how GnuTLS takes sockets: as file descriptors passed
54 in. For an Emacs process socket, infd and outfd are the
55 same but we use this two-argument version for clarity. */
56 gnutls_transport_set_ptr2 (state,
57 (gnutls_transport_ptr_t) (long) proc->infd,
58 (gnutls_transport_ptr_t) (long) proc->outfd);
60 proc->gnutls_initstage = GNUTLS_STAGE_TRANSPORT_POINTERS_SET;
63 ret = gnutls_handshake (state);
64 proc->gnutls_initstage = GNUTLS_STAGE_HANDSHAKE_TRIED;
66 if (ret == GNUTLS_E_SUCCESS)
68 /* here we're finally done. */
69 proc->gnutls_initstage = GNUTLS_STAGE_READY;
73 int
74 emacs_gnutls_write (int fildes, struct Lisp_Process *proc, char *buf,
75 unsigned int nbyte)
77 register int rtnval, bytes_written;
78 gnutls_session_t state = proc->gnutls_state;
80 if (proc->gnutls_initstage != GNUTLS_STAGE_READY) {
81 #ifdef EWOULDBLOCK
82 errno = EWOULDBLOCK;
83 #endif
84 #ifdef EAGAIN
85 errno = EAGAIN;
86 #endif
87 return -1;
90 bytes_written = 0;
92 while (nbyte > 0)
94 rtnval = gnutls_write (state, buf, nbyte);
96 if (rtnval < 0)
98 if (rtnval == GNUTLS_E_AGAIN || rtnval == GNUTLS_E_INTERRUPTED)
99 continue;
100 else
101 return (bytes_written ? bytes_written : -1);
104 buf += rtnval;
105 nbyte -= rtnval;
106 bytes_written += rtnval;
109 return (bytes_written);
113 emacs_gnutls_read (int fildes, struct Lisp_Process *proc, char *buf,
114 unsigned int nbyte)
116 register int rtnval;
117 gnutls_session_t state = proc->gnutls_state;
119 if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
121 emacs_gnutls_handshake (proc);
122 return -1;
125 rtnval = gnutls_read (state, buf, nbyte);
126 if (rtnval >= 0)
127 return rtnval;
128 else {
129 if (rtnval == GNUTLS_E_AGAIN ||
130 rtnval == GNUTLS_E_INTERRUPTED)
131 return -1;
132 else
133 return 0;
137 /* convert an integer error to a Lisp_Object; it will be either a
138 known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or
139 simply the integer value of the error. GNUTLS_E_SUCCESS is mapped
140 to Qt. */
141 static Lisp_Object
142 gnutls_make_error (int error)
144 switch (error)
146 case GNUTLS_E_SUCCESS:
147 return Qt;
148 case GNUTLS_E_AGAIN:
149 return Qgnutls_e_again;
150 case GNUTLS_E_INTERRUPTED:
151 return Qgnutls_e_interrupted;
152 case GNUTLS_E_INVALID_SESSION:
153 return Qgnutls_e_invalid_session;
156 return make_number (error);
159 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage, Sgnutls_get_initstage, 1, 1, 0,
160 doc: /* Return the GnuTLS init stage of process PROC.
161 See also `gnutls-boot'. */)
162 (Lisp_Object proc)
164 CHECK_PROCESS (proc);
166 return make_number (GNUTLS_INITSTAGE (proc));
169 DEFUN ("gnutls-errorp", Fgnutls_errorp, Sgnutls_errorp, 1, 1, 0,
170 doc: /* Return t if ERROR indicates a GnuTLS problem.
171 ERROR is an integer or a symbol with an integer `gnutls-code' property.
172 usage: (gnutls-errorp ERROR) */)
173 (Lisp_Object err)
175 if (EQ (err, Qt)) return Qnil;
177 return Qt;
180 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp, Sgnutls_error_fatalp, 1, 1, 0,
181 doc: /* Check if ERROR is fatal.
182 ERROR is an integer or a symbol with an integer `gnutls-code' property.
183 usage: (gnutls-error-fatalp ERROR) */)
184 (Lisp_Object err)
186 Lisp_Object code;
188 if (EQ (err, Qt)) return Qnil;
190 if (SYMBOLP (err))
192 code = Fget (err, Qgnutls_code);
193 if (NUMBERP (code))
195 err = code;
197 else
199 error ("Symbol has no numeric gnutls-code property");
203 if (!NUMBERP (err))
204 error ("Not an error symbol or code");
206 if (0 == gnutls_error_is_fatal (XINT (err)))
207 return Qnil;
209 return Qt;
212 DEFUN ("gnutls-error-string", Fgnutls_error_string, Sgnutls_error_string, 1, 1, 0,
213 doc: /* Return a description of ERROR.
214 ERROR is an integer or a symbol with an integer `gnutls-code' property.
215 usage: (gnutls-error-string ERROR) */)
216 (Lisp_Object err)
218 Lisp_Object code;
220 if (EQ (err, Qt)) return build_string ("Not an error");
222 if (SYMBOLP (err))
224 code = Fget (err, Qgnutls_code);
225 if (NUMBERP (code))
227 err = code;
229 else
231 return build_string ("Symbol has no numeric gnutls-code property");
235 if (!NUMBERP (err))
236 return build_string ("Not an error symbol or code");
238 return build_string (gnutls_strerror (XINT (err)));
241 DEFUN ("gnutls-deinit", Fgnutls_deinit, Sgnutls_deinit, 1, 1, 0,
242 doc: /* Deallocate GnuTLS resources associated with process PROC.
243 See also `gnutls-init'. */)
244 (Lisp_Object proc)
246 gnutls_session_t state;
248 CHECK_PROCESS (proc);
249 state = XPROCESS (proc)->gnutls_state;
251 if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_INIT)
253 gnutls_deinit (state);
254 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT - 1;
257 return Qt;
260 /* Initializes global GnuTLS state to defaults.
261 Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
262 Returns zero on success. */
263 static Lisp_Object
264 gnutls_emacs_global_init (void)
266 int ret = GNUTLS_E_SUCCESS;
268 if (!global_initialized)
269 ret = gnutls_global_init ();
271 global_initialized = 1;
273 return gnutls_make_error (ret);
276 /* Deinitializes global GnuTLS state.
277 See also `gnutls-global-init'. */
278 static Lisp_Object
279 gnutls_emacs_global_deinit (void)
281 if (global_initialized)
282 gnutls_global_deinit ();
284 global_initialized = 0;
286 return gnutls_make_error (GNUTLS_E_SUCCESS);
289 static void
290 gnutls_log_function (int level, const char* string)
292 message ("gnutls.c: [%d] %s", level, string);
295 static void
296 gnutls_log_function2 (int level, const char* string, const char* extra)
298 message ("gnutls.c: [%d] %s %s", level, string, extra);
301 DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
302 doc: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
303 Currently only client mode is supported. Returns a success/failure
304 value you can check with `gnutls-errorp'.
306 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
307 PROPLIST is a property list with the following keys:
309 :priority is a GnuTLS priority string, defaults to "NORMAL".
310 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
311 :keyfiles is a list of PEM-encoded key files for `gnutls-x509pki'.
312 :callbacks is an alist of callback functions (TODO).
313 :loglevel is the debug level requested from GnuTLS, try 4.
315 The debug level will be set for this process AND globally for GnuTLS.
316 So if you set it higher or lower at any point, it affects global
317 debugging.
319 Note that the priority is set on the client. The server does not use
320 the protocols's priority except for disabling protocols that were not
321 specified.
323 Processes must be initialized with this function before other GnuTLS
324 functions are used. This function allocates resources which can only
325 be deallocated by calling `gnutls-deinit' or by calling it again.
327 Each authentication type may need additional information in order to
328 work. For X.509 PKI (`gnutls-x509pki'), you probably need at least
329 one trustfile (usually a CA bundle). */)
330 (Lisp_Object proc, Lisp_Object type, Lisp_Object proplist)
332 int ret = GNUTLS_E_SUCCESS;
334 int max_log_level = 0;
336 /* TODO: GNUTLS_X509_FMT_DER is also an option. */
337 int file_format = GNUTLS_X509_FMT_PEM;
339 gnutls_session_t state;
340 gnutls_certificate_credentials_t x509_cred;
341 gnutls_anon_client_credentials_t anon_cred;
342 Lisp_Object global_init;
343 char* priority_string_ptr = "NORMAL"; /* default priority string. */
344 Lisp_Object tail;
346 /* Placeholders for the property list elements. */
347 Lisp_Object priority_string;
348 Lisp_Object trustfiles;
349 Lisp_Object keyfiles;
350 Lisp_Object callbacks;
351 Lisp_Object loglevel;
353 CHECK_PROCESS (proc);
354 CHECK_SYMBOL (type);
355 CHECK_LIST (proplist);
357 priority_string = Fplist_get (proplist, Qgnutls_bootprop_priority);
358 trustfiles = Fplist_get (proplist, Qgnutls_bootprop_trustfiles);
359 keyfiles = Fplist_get (proplist, Qgnutls_bootprop_keyfiles);
360 callbacks = Fplist_get (proplist, Qgnutls_bootprop_callbacks);
361 loglevel = Fplist_get (proplist, Qgnutls_bootprop_loglevel);
363 state = XPROCESS (proc)->gnutls_state;
364 XPROCESS (proc)->gnutls_p = 1;
366 if (NUMBERP (loglevel))
368 gnutls_global_set_log_function (gnutls_log_function);
369 gnutls_global_set_log_level (XINT (loglevel));
370 max_log_level = XINT (loglevel);
371 XPROCESS (proc)->gnutls_log_level = max_log_level;
374 /* always initialize globals. */
375 global_init = gnutls_emacs_global_init ();
376 if (! NILP (Fgnutls_errorp (global_init)))
377 return global_init;
379 /* deinit and free resources. */
380 if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_CRED_ALLOC)
382 GNUTLS_LOG (1, max_log_level, "deallocating credentials");
384 if (EQ (type, Qgnutls_x509pki))
386 GNUTLS_LOG (2, max_log_level, "deallocating x509 credentials");
387 x509_cred = XPROCESS (proc)->gnutls_x509_cred;
388 gnutls_certificate_free_credentials (x509_cred);
390 else if (EQ (type, Qgnutls_anon))
392 GNUTLS_LOG (2, max_log_level, "deallocating anon credentials");
393 anon_cred = XPROCESS (proc)->gnutls_anon_cred;
394 gnutls_anon_free_client_credentials (anon_cred);
396 else
398 error ("unknown credential type");
399 ret = GNUTLS_EMACS_ERROR_INVALID_TYPE;
402 if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_INIT)
404 GNUTLS_LOG (1, max_log_level, "deallocating x509 credentials");
405 Fgnutls_deinit (proc);
409 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_EMPTY;
411 GNUTLS_LOG (1, max_log_level, "allocating credentials");
413 if (EQ (type, Qgnutls_x509pki))
415 GNUTLS_LOG (2, max_log_level, "allocating x509 credentials");
416 x509_cred = XPROCESS (proc)->gnutls_x509_cred;
417 if (gnutls_certificate_allocate_credentials (&x509_cred) < 0)
418 memory_full ();
420 else if (EQ (type, Qgnutls_anon))
422 GNUTLS_LOG (2, max_log_level, "allocating anon credentials");
423 anon_cred = XPROCESS (proc)->gnutls_anon_cred;
424 if (gnutls_anon_allocate_client_credentials (&anon_cred) < 0)
425 memory_full ();
427 else
429 error ("unknown credential type");
430 ret = GNUTLS_EMACS_ERROR_INVALID_TYPE;
433 if (ret < GNUTLS_E_SUCCESS)
434 return gnutls_make_error (ret);
436 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_ALLOC;
438 if (EQ (type, Qgnutls_x509pki))
440 for (tail = trustfiles; !NILP (tail); tail = Fcdr (tail))
442 Lisp_Object trustfile = Fcar (tail);
443 if (STRINGP (trustfile))
445 GNUTLS_LOG2 (1, max_log_level, "setting the trustfile: ",
446 SDATA (trustfile));
447 ret = gnutls_certificate_set_x509_trust_file
448 (x509_cred,
449 SDATA (trustfile),
450 file_format);
452 if (ret < GNUTLS_E_SUCCESS)
453 return gnutls_make_error (ret);
455 else
457 error ("Sorry, GnuTLS can't use non-string trustfile %s",
458 trustfile);
462 for (tail = keyfiles; !NILP (tail); tail = Fcdr (tail))
464 Lisp_Object keyfile = Fcar (tail);
465 if (STRINGP (keyfile))
467 GNUTLS_LOG2 (1, max_log_level, "setting the keyfile: ",
468 SDATA (keyfile));
469 ret = gnutls_certificate_set_x509_crl_file
470 (x509_cred,
471 SDATA (keyfile),
472 file_format);
474 if (ret < GNUTLS_E_SUCCESS)
475 return gnutls_make_error (ret);
477 else
479 error ("Sorry, GnuTLS can't use non-string keyfile %s",
480 keyfile);
485 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_FILES;
487 GNUTLS_LOG (1, max_log_level, "gnutls_init");
489 ret = gnutls_init (&state, GNUTLS_CLIENT);
491 if (ret < GNUTLS_E_SUCCESS)
492 return gnutls_make_error (ret);
494 XPROCESS (proc)->gnutls_state = state;
496 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT;
498 if (STRINGP (priority_string))
500 priority_string_ptr = (char*) SDATA (priority_string);
501 GNUTLS_LOG2 (1, max_log_level, "got non-default priority string:",
502 priority_string_ptr);
504 else
506 GNUTLS_LOG2 (1, max_log_level, "using default priority string:",
507 priority_string_ptr);
510 GNUTLS_LOG (1, max_log_level, "setting the priority string");
512 ret = gnutls_priority_set_direct (state,
513 priority_string_ptr,
514 NULL);
516 if (ret < GNUTLS_E_SUCCESS)
517 return gnutls_make_error (ret);
519 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_PRIORITY;
521 if (EQ (type, Qgnutls_x509pki))
523 ret = gnutls_cred_set (state, GNUTLS_CRD_CERTIFICATE, x509_cred);
525 else if (EQ (type, Qgnutls_anon))
527 ret = gnutls_cred_set (state, GNUTLS_CRD_ANON, anon_cred);
529 else
531 error ("unknown credential type");
532 ret = GNUTLS_EMACS_ERROR_INVALID_TYPE;
535 if (ret < GNUTLS_E_SUCCESS)
536 return gnutls_make_error (ret);
538 XPROCESS (proc)->gnutls_anon_cred = anon_cred;
539 XPROCESS (proc)->gnutls_x509_cred = x509_cred;
540 XPROCESS (proc)->gnutls_cred_type = type;
542 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET;
544 emacs_gnutls_handshake (XPROCESS (proc));
546 return gnutls_make_error (GNUTLS_E_SUCCESS);
549 DEFUN ("gnutls-bye", Fgnutls_bye,
550 Sgnutls_bye, 2, 2, 0,
551 doc: /* Terminate current GnuTLS connection for process PROC.
552 The connection should have been initiated using `gnutls-handshake'.
554 If CONT is not nil the TLS connection gets terminated and further
555 receives and sends will be disallowed. If the return value is zero you
556 may continue using the connection. If CONT is nil, GnuTLS actually
557 sends an alert containing a close request and waits for the peer to
558 reply with the same message. In order to reuse the connection you
559 should wait for an EOF from the peer.
561 This function may also return `gnutls-e-again', or
562 `gnutls-e-interrupted'. */)
563 (Lisp_Object proc, Lisp_Object cont)
565 gnutls_session_t state;
566 int ret;
568 CHECK_PROCESS (proc);
570 state = XPROCESS (proc)->gnutls_state;
572 ret = gnutls_bye (state,
573 NILP (cont) ? GNUTLS_SHUT_RDWR : GNUTLS_SHUT_WR);
575 return gnutls_make_error (ret);
578 void
579 syms_of_gnutls (void)
581 global_initialized = 0;
583 Qgnutls_code = intern_c_string ("gnutls-code");
584 staticpro (&Qgnutls_code);
586 Qgnutls_anon = intern_c_string ("gnutls-anon");
587 staticpro (&Qgnutls_anon);
589 Qgnutls_x509pki = intern_c_string ("gnutls-x509pki");
590 staticpro (&Qgnutls_x509pki);
592 Qgnutls_bootprop_priority = intern_c_string (":priority");
593 staticpro (&Qgnutls_bootprop_priority);
595 Qgnutls_bootprop_trustfiles = intern_c_string (":trustfiles");
596 staticpro (&Qgnutls_bootprop_trustfiles);
598 Qgnutls_bootprop_keyfiles = intern_c_string (":keyfiles");
599 staticpro (&Qgnutls_bootprop_keyfiles);
601 Qgnutls_bootprop_callbacks = intern_c_string (":callbacks");
602 staticpro (&Qgnutls_bootprop_callbacks);
604 Qgnutls_bootprop_loglevel = intern_c_string (":loglevel");
605 staticpro (&Qgnutls_bootprop_loglevel);
607 Qgnutls_e_interrupted = intern_c_string ("gnutls-e-interrupted");
608 staticpro (&Qgnutls_e_interrupted);
609 Fput (Qgnutls_e_interrupted, Qgnutls_code,
610 make_number (GNUTLS_E_INTERRUPTED));
612 Qgnutls_e_again = intern_c_string ("gnutls-e-again");
613 staticpro (&Qgnutls_e_again);
614 Fput (Qgnutls_e_again, Qgnutls_code,
615 make_number (GNUTLS_E_AGAIN));
617 Qgnutls_e_invalid_session = intern_c_string ("gnutls-e-invalid-session");
618 staticpro (&Qgnutls_e_invalid_session);
619 Fput (Qgnutls_e_invalid_session, Qgnutls_code,
620 make_number (GNUTLS_E_INVALID_SESSION));
622 Qgnutls_e_not_ready_for_handshake =
623 intern_c_string ("gnutls-e-not-ready-for-handshake");
624 staticpro (&Qgnutls_e_not_ready_for_handshake);
625 Fput (Qgnutls_e_not_ready_for_handshake, Qgnutls_code,
626 make_number (GNUTLS_E_APPLICATION_ERROR_MIN));
628 defsubr (&Sgnutls_get_initstage);
629 defsubr (&Sgnutls_errorp);
630 defsubr (&Sgnutls_error_fatalp);
631 defsubr (&Sgnutls_error_string);
632 defsubr (&Sgnutls_boot);
633 defsubr (&Sgnutls_deinit);
634 defsubr (&Sgnutls_bye);
636 #endif