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/>. */
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
)
87 rtnval
= gnutls_write (state
, buf
, nbyte
);
94 return (bytes_written
? bytes_written
: -1);
99 bytes_written
+= rtnval
;
101 fsync (STDOUT_FILENO
);
103 return (bytes_written
);
107 emacs_gnutls_read (int fildes
, struct Lisp_Process
*proc
, char *buf
,
111 gnutls_session_t state
= proc
->gnutls_state
;
113 if (proc
->gnutls_initstage
!= GNUTLS_STAGE_READY
)
115 emacs_gnutls_handshake (proc
);
119 rtnval
= gnutls_read (state
, buf
, nbyte
);
126 /* convert an integer error to a Lisp_Object; it will be either a
127 known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or
128 simply the integer value of the error. GNUTLS_E_SUCCESS is mapped
131 gnutls_make_error (int error
)
135 case GNUTLS_E_SUCCESS
:
138 return Qgnutls_e_again
;
139 case GNUTLS_E_INTERRUPTED
:
140 return Qgnutls_e_interrupted
;
141 case GNUTLS_E_INVALID_SESSION
:
142 return Qgnutls_e_invalid_session
;
145 return make_number (error
);
148 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage
, Sgnutls_get_initstage
, 1, 1, 0,
149 doc
: /* Return the GnuTLS init stage of process PROC.
150 See also `gnutls-boot'. */)
153 CHECK_PROCESS (proc
);
155 return make_number (GNUTLS_INITSTAGE (proc
));
158 DEFUN ("gnutls-errorp", Fgnutls_errorp
, Sgnutls_errorp
, 1, 1, 0,
159 doc
: /* Return t if ERROR indicates a GnuTLS problem.
160 ERROR is an integer or a symbol with an integer `gnutls-code' property.
161 usage: (gnutls-errorp ERROR) */)
164 if (EQ (err
, Qt
)) return Qnil
;
169 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp
, Sgnutls_error_fatalp
, 1, 1, 0,
170 doc
: /* Check if ERROR is fatal.
171 ERROR is an integer or a symbol with an integer `gnutls-code' property.
172 usage: (gnutls-error-fatalp ERROR) */)
177 if (EQ (err
, Qt
)) return Qnil
;
181 code
= Fget (err
, Qgnutls_code
);
188 error ("Symbol has no numeric gnutls-code property");
193 error ("Not an error symbol or code");
195 if (0 == gnutls_error_is_fatal (XINT (err
)))
201 DEFUN ("gnutls-error-string", Fgnutls_error_string
, Sgnutls_error_string
, 1, 1, 0,
202 doc
: /* Return a description of ERROR.
203 ERROR is an integer or a symbol with an integer `gnutls-code' property.
204 usage: (gnutls-error-string ERROR) */)
209 if (EQ (err
, Qt
)) return build_string ("Not an error");
213 code
= Fget (err
, Qgnutls_code
);
220 return build_string ("Symbol has no numeric gnutls-code property");
225 return build_string ("Not an error symbol or code");
227 return build_string (gnutls_strerror (XINT (err
)));
230 DEFUN ("gnutls-deinit", Fgnutls_deinit
, Sgnutls_deinit
, 1, 1, 0,
231 doc
: /* Deallocate GnuTLS resources associated with process PROC.
232 See also `gnutls-init'. */)
235 gnutls_session_t state
;
237 CHECK_PROCESS (proc
);
238 state
= XPROCESS (proc
)->gnutls_state
;
240 if (GNUTLS_INITSTAGE (proc
) >= GNUTLS_STAGE_INIT
)
242 gnutls_deinit (state
);
243 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_INIT
- 1;
249 /* Initializes global GnuTLS state to defaults.
250 Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
251 Returns zero on success. */
253 gnutls_emacs_global_init (void)
255 int ret
= GNUTLS_E_SUCCESS
;
257 if (!global_initialized
)
258 ret
= gnutls_global_init ();
260 global_initialized
= 1;
262 return gnutls_make_error (ret
);
265 /* Deinitializes global GnuTLS state.
266 See also `gnutls-global-init'. */
268 gnutls_emacs_global_deinit (void)
270 if (global_initialized
)
271 gnutls_global_deinit ();
273 global_initialized
= 0;
275 return gnutls_make_error (GNUTLS_E_SUCCESS
);
279 gnutls_log_function (int level
, const char* string
)
281 message ("gnutls.c: [%d] %s", level
, string
);
285 gnutls_log_function2 (int level
, const char* string
, const char* extra
)
287 message ("gnutls.c: [%d] %s %s", level
, string
, extra
);
290 DEFUN ("gnutls-boot", Fgnutls_boot
, Sgnutls_boot
, 3, 3, 0,
291 doc
: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
292 Currently only client mode is supported. Returns a success/failure
293 value you can check with `gnutls-errorp'.
295 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
296 PROPLIST is a property list with the following keys:
298 :priority is a GnuTLS priority string, defaults to "NORMAL".
299 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
300 :keyfiles is a list of PEM-encoded key files for `gnutls-x509pki'.
301 :callbacks is an alist of callback functions (TODO).
302 :loglevel is the debug level requested from GnuTLS, try 4.
304 The debug level will be set for this process AND globally for GnuTLS.
305 So if you set it higher or lower at any point, it affects global
308 Note that the priority is set on the client. The server does not use
309 the protocols's priority except for disabling protocols that were not
312 Processes must be initialized with this function before other GnuTLS
313 functions are used. This function allocates resources which can only
314 be deallocated by calling `gnutls-deinit' or by calling it again.
316 Each authentication type may need additional information in order to
317 work. For X.509 PKI (`gnutls-x509pki'), you probably need at least
318 one trustfile (usually a CA bundle). */)
319 (Lisp_Object proc
, Lisp_Object type
, Lisp_Object proplist
)
321 int ret
= GNUTLS_E_SUCCESS
;
323 int max_log_level
= 0;
325 /* TODO: GNUTLS_X509_FMT_DER is also an option. */
326 int file_format
= GNUTLS_X509_FMT_PEM
;
328 gnutls_session_t state
;
329 gnutls_certificate_credentials_t x509_cred
;
330 gnutls_anon_client_credentials_t anon_cred
;
331 Lisp_Object global_init
;
332 char* priority_string_ptr
= "NORMAL"; /* default priority string. */
335 /* Placeholders for the property list elements. */
336 Lisp_Object priority_string
;
337 Lisp_Object trustfiles
;
338 Lisp_Object keyfiles
;
339 Lisp_Object callbacks
;
340 Lisp_Object loglevel
;
342 CHECK_PROCESS (proc
);
344 CHECK_LIST (proplist
);
346 priority_string
= Fplist_get (proplist
, Qgnutls_bootprop_priority
);
347 trustfiles
= Fplist_get (proplist
, Qgnutls_bootprop_trustfiles
);
348 keyfiles
= Fplist_get (proplist
, Qgnutls_bootprop_keyfiles
);
349 callbacks
= Fplist_get (proplist
, Qgnutls_bootprop_callbacks
);
350 loglevel
= Fplist_get (proplist
, Qgnutls_bootprop_loglevel
);
352 state
= XPROCESS (proc
)->gnutls_state
;
353 XPROCESS (proc
)->gnutls_p
= 1;
355 if (NUMBERP (loglevel
))
357 gnutls_global_set_log_function (gnutls_log_function
);
358 gnutls_global_set_log_level (XINT (loglevel
));
359 max_log_level
= XINT (loglevel
);
360 XPROCESS (proc
)->gnutls_log_level
= max_log_level
;
363 /* always initialize globals. */
364 global_init
= gnutls_emacs_global_init ();
365 if (! NILP (Fgnutls_errorp (global_init
)))
368 /* deinit and free resources. */
369 if (GNUTLS_INITSTAGE (proc
) >= GNUTLS_STAGE_CRED_ALLOC
)
371 GNUTLS_LOG (1, max_log_level
, "deallocating credentials");
373 if (EQ (type
, Qgnutls_x509pki
))
375 GNUTLS_LOG (2, max_log_level
, "deallocating x509 credentials");
376 x509_cred
= XPROCESS (proc
)->gnutls_x509_cred
;
377 gnutls_certificate_free_credentials (x509_cred
);
379 else if (EQ (type
, Qgnutls_anon
))
381 GNUTLS_LOG (2, max_log_level
, "deallocating anon credentials");
382 anon_cred
= XPROCESS (proc
)->gnutls_anon_cred
;
383 gnutls_anon_free_client_credentials (anon_cred
);
387 error ("unknown credential type");
388 ret
= GNUTLS_EMACS_ERROR_INVALID_TYPE
;
391 if (GNUTLS_INITSTAGE (proc
) >= GNUTLS_STAGE_INIT
)
393 GNUTLS_LOG (1, max_log_level
, "deallocating x509 credentials");
394 Fgnutls_deinit (proc
);
398 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_EMPTY
;
400 GNUTLS_LOG (1, max_log_level
, "allocating credentials");
402 if (EQ (type
, Qgnutls_x509pki
))
404 GNUTLS_LOG (2, max_log_level
, "allocating x509 credentials");
405 x509_cred
= XPROCESS (proc
)->gnutls_x509_cred
;
406 if (gnutls_certificate_allocate_credentials (&x509_cred
) < 0)
409 else if (EQ (type
, Qgnutls_anon
))
411 GNUTLS_LOG (2, max_log_level
, "allocating anon credentials");
412 anon_cred
= XPROCESS (proc
)->gnutls_anon_cred
;
413 if (gnutls_anon_allocate_client_credentials (&anon_cred
) < 0)
418 error ("unknown credential type");
419 ret
= GNUTLS_EMACS_ERROR_INVALID_TYPE
;
422 if (ret
< GNUTLS_E_SUCCESS
)
423 return gnutls_make_error (ret
);
425 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CRED_ALLOC
;
427 if (EQ (type
, Qgnutls_x509pki
))
429 for (tail
= trustfiles
; !NILP (tail
); tail
= Fcdr (tail
))
431 Lisp_Object trustfile
= Fcar (tail
);
432 if (STRINGP (trustfile
))
434 GNUTLS_LOG2 (1, max_log_level
, "setting the trustfile: ",
436 ret
= gnutls_certificate_set_x509_trust_file
441 if (ret
< GNUTLS_E_SUCCESS
)
442 return gnutls_make_error (ret
);
446 error ("Sorry, GnuTLS can't use non-string trustfile %s",
451 for (tail
= keyfiles
; !NILP (tail
); tail
= Fcdr (tail
))
453 Lisp_Object keyfile
= Fcar (tail
);
454 if (STRINGP (keyfile
))
456 GNUTLS_LOG2 (1, max_log_level
, "setting the keyfile: ",
458 ret
= gnutls_certificate_set_x509_crl_file
463 if (ret
< GNUTLS_E_SUCCESS
)
464 return gnutls_make_error (ret
);
468 error ("Sorry, GnuTLS can't use non-string keyfile %s",
474 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_FILES
;
476 GNUTLS_LOG (1, max_log_level
, "gnutls_init");
478 ret
= gnutls_init (&state
, GNUTLS_CLIENT
);
480 if (ret
< GNUTLS_E_SUCCESS
)
481 return gnutls_make_error (ret
);
483 XPROCESS (proc
)->gnutls_state
= state
;
485 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_INIT
;
487 if (STRINGP (priority_string
))
489 priority_string_ptr
= (char*) SDATA (priority_string
);
490 GNUTLS_LOG2 (1, max_log_level
, "got non-default priority string:",
491 priority_string_ptr
);
495 GNUTLS_LOG2 (1, max_log_level
, "using default priority string:",
496 priority_string_ptr
);
499 GNUTLS_LOG (1, max_log_level
, "setting the priority string");
501 ret
= gnutls_priority_set_direct (state
,
505 if (ret
< GNUTLS_E_SUCCESS
)
506 return gnutls_make_error (ret
);
508 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_PRIORITY
;
510 if (EQ (type
, Qgnutls_x509pki
))
512 ret
= gnutls_cred_set (state
, GNUTLS_CRD_CERTIFICATE
, x509_cred
);
514 else if (EQ (type
, Qgnutls_anon
))
516 ret
= gnutls_cred_set (state
, GNUTLS_CRD_ANON
, anon_cred
);
520 error ("unknown credential type");
521 ret
= GNUTLS_EMACS_ERROR_INVALID_TYPE
;
524 if (ret
< GNUTLS_E_SUCCESS
)
525 return gnutls_make_error (ret
);
527 XPROCESS (proc
)->gnutls_anon_cred
= anon_cred
;
528 XPROCESS (proc
)->gnutls_x509_cred
= x509_cred
;
529 XPROCESS (proc
)->gnutls_cred_type
= type
;
531 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CRED_SET
;
533 emacs_gnutls_handshake (XPROCESS (proc
));
535 return gnutls_make_error (GNUTLS_E_SUCCESS
);
538 DEFUN ("gnutls-bye", Fgnutls_bye
,
539 Sgnutls_bye
, 2, 2, 0,
540 doc
: /* Terminate current GnuTLS connection for process PROC.
541 The connection should have been initiated using `gnutls-handshake'.
543 If CONT is not nil the TLS connection gets terminated and further
544 receives and sends will be disallowed. If the return value is zero you
545 may continue using the connection. If CONT is nil, GnuTLS actually
546 sends an alert containing a close request and waits for the peer to
547 reply with the same message. In order to reuse the connection you
548 should wait for an EOF from the peer.
550 This function may also return `gnutls-e-again', or
551 `gnutls-e-interrupted'. */)
552 (Lisp_Object proc
, Lisp_Object cont
)
554 gnutls_session_t state
;
557 CHECK_PROCESS (proc
);
559 state
= XPROCESS (proc
)->gnutls_state
;
561 ret
= gnutls_bye (state
,
562 NILP (cont
) ? GNUTLS_SHUT_RDWR
: GNUTLS_SHUT_WR
);
564 return gnutls_make_error (ret
);
568 syms_of_gnutls (void)
570 global_initialized
= 0;
572 Qgnutls_code
= intern_c_string ("gnutls-code");
573 staticpro (&Qgnutls_code
);
575 Qgnutls_anon
= intern_c_string ("gnutls-anon");
576 staticpro (&Qgnutls_anon
);
578 Qgnutls_x509pki
= intern_c_string ("gnutls-x509pki");
579 staticpro (&Qgnutls_x509pki
);
581 Qgnutls_bootprop_priority
= intern_c_string ("priority");
582 staticpro (&Qgnutls_bootprop_priority
);
584 Qgnutls_bootprop_trustfiles
= intern_c_string ("trustfiles");
585 staticpro (&Qgnutls_bootprop_trustfiles
);
587 Qgnutls_bootprop_keyfiles
= intern_c_string ("keyfiles");
588 staticpro (&Qgnutls_bootprop_keyfiles
);
590 Qgnutls_bootprop_callbacks
= intern_c_string ("callbacks");
591 staticpro (&Qgnutls_bootprop_callbacks
);
593 Qgnutls_bootprop_loglevel
= intern_c_string ("loglevel");
594 staticpro (&Qgnutls_bootprop_loglevel
);
596 Qgnutls_e_interrupted
= intern_c_string ("gnutls-e-interrupted");
597 staticpro (&Qgnutls_e_interrupted
);
598 Fput (Qgnutls_e_interrupted
, Qgnutls_code
,
599 make_number (GNUTLS_E_INTERRUPTED
));
601 Qgnutls_e_again
= intern_c_string ("gnutls-e-again");
602 staticpro (&Qgnutls_e_again
);
603 Fput (Qgnutls_e_again
, Qgnutls_code
,
604 make_number (GNUTLS_E_AGAIN
));
606 Qgnutls_e_invalid_session
= intern_c_string ("gnutls-e-invalid-session");
607 staticpro (&Qgnutls_e_invalid_session
);
608 Fput (Qgnutls_e_invalid_session
, Qgnutls_code
,
609 make_number (GNUTLS_E_INVALID_SESSION
));
611 Qgnutls_e_not_ready_for_handshake
=
612 intern_c_string ("gnutls-e-not-ready-for-handshake");
613 staticpro (&Qgnutls_e_not_ready_for_handshake
);
614 Fput (Qgnutls_e_not_ready_for_handshake
, Qgnutls_code
,
615 make_number (GNUTLS_E_APPLICATION_ERROR_MIN
));
617 defsubr (&Sgnutls_get_initstage
);
618 defsubr (&Sgnutls_errorp
);
619 defsubr (&Sgnutls_error_fatalp
);
620 defsubr (&Sgnutls_error_string
);
621 defsubr (&Sgnutls_boot
);
622 defsubr (&Sgnutls_deinit
);
623 defsubr (&Sgnutls_bye
);