1 /* GnuTLS glue for GNU Emacs.
2 Copyright (C) 2010-2011 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/>. */
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
;
43 emacs_gnutls_handshake (struct Lisp_Process
*proc
)
45 gnutls_session_t state
= proc
->gnutls_state
;
48 if (proc
->gnutls_initstage
< GNUTLS_STAGE_HANDSHAKE_CANDO
)
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
;
74 emacs_gnutls_write (int fildes
, struct Lisp_Process
*proc
, char *buf
,
77 register int rtnval
, bytes_written
;
78 gnutls_session_t state
= proc
->gnutls_state
;
80 if (proc
->gnutls_initstage
!= GNUTLS_STAGE_READY
) {
94 rtnval
= gnutls_write (state
, buf
, nbyte
);
98 if (rtnval
== GNUTLS_E_AGAIN
|| rtnval
== GNUTLS_E_INTERRUPTED
)
101 return (bytes_written
? bytes_written
: -1);
106 bytes_written
+= rtnval
;
109 return (bytes_written
);
113 emacs_gnutls_read (int fildes
, struct Lisp_Process
*proc
, char *buf
,
117 gnutls_session_t state
= proc
->gnutls_state
;
119 if (proc
->gnutls_initstage
!= GNUTLS_STAGE_READY
)
121 emacs_gnutls_handshake (proc
);
125 rtnval
= gnutls_read (state
, buf
, nbyte
);
129 if (rtnval
== GNUTLS_E_AGAIN
||
130 rtnval
== GNUTLS_E_INTERRUPTED
)
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
142 gnutls_make_error (int error
)
146 case GNUTLS_E_SUCCESS
:
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'. */)
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) */)
175 if (EQ (err
, Qt
)) return Qnil
;
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) */)
188 if (EQ (err
, Qt
)) return Qnil
;
192 code
= Fget (err
, Qgnutls_code
);
199 error ("Symbol has no numeric gnutls-code property");
204 error ("Not an error symbol or code");
206 if (0 == gnutls_error_is_fatal (XINT (err
)))
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) */)
220 if (EQ (err
, Qt
)) return build_string ("Not an error");
224 code
= Fget (err
, Qgnutls_code
);
231 return build_string ("Symbol has no numeric gnutls-code property");
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'. */)
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;
260 /* Initializes global GnuTLS state to defaults.
261 Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
262 Returns zero on success. */
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'. */
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
);
290 gnutls_log_function (int level
, const char* string
)
292 message ("gnutls.c: [%d] %s", level
, string
);
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
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
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. */
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
);
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
)))
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
);
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)
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)
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: ",
447 ret
= gnutls_certificate_set_x509_trust_file
452 if (ret
< GNUTLS_E_SUCCESS
)
453 return gnutls_make_error (ret
);
457 error ("Sorry, GnuTLS can't use non-string trustfile %s",
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: ",
469 ret
= gnutls_certificate_set_x509_crl_file
474 if (ret
< GNUTLS_E_SUCCESS
)
475 return gnutls_make_error (ret
);
479 error ("Sorry, GnuTLS can't use non-string keyfile %s",
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
= SSDATA (priority_string
);
501 GNUTLS_LOG2 (1, max_log_level
, "got non-default priority string:",
502 priority_string_ptr
);
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
,
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
);
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
;
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
);
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
);