diff options
Diffstat (limited to 'src/gnutls.c')
| -rw-r--r-- | src/gnutls.c | 827 |
1 files changed, 613 insertions, 214 deletions
diff --git a/src/gnutls.c b/src/gnutls.c index d7a1399f106..a0de0238c47 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -1,5 +1,5 @@ /* GnuTLS glue for GNU Emacs. - Copyright (C) 2010-2017 Free Software Foundation, Inc. + Copyright (C) 2010-2022 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -25,29 +25,62 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "gnutls.h" #include "coding.h" #include "buffer.h" +#include "pdumper.h" -#if 0x030014 <= GNUTLS_VERSION_NUMBER -# define HAVE_GNUTLS_X509_SYSTEM_TRUST -#endif +#ifdef HAVE_GNUTLS + +# if GNUTLS_VERSION_NUMBER >= 0x030014 +# define HAVE_GNUTLS_X509_SYSTEM_TRUST +# endif + +# if GNUTLS_VERSION_NUMBER >= 0x030200 +# define HAVE_GNUTLS_CIPHER_GET_IV_SIZE +# endif + +# if GNUTLS_VERSION_NUMBER >= 0x030202 +# define HAVE_GNUTLS_CIPHER_GET_TAG_SIZE +# define HAVE_GNUTLS_DIGEST_LIST /* also gnutls_digest_get_name */ +# endif + +# if GNUTLS_VERSION_NUMBER >= 0x030205 +# define HAVE_GNUTLS_EXT__DUMBFW +# endif + +# if GNUTLS_VERSION_NUMBER >= 0x030400 +# define HAVE_GNUTLS_ETM_STATUS +# endif + +# if GNUTLS_VERSION_NUMBER < 0x030600 +# define HAVE_GNUTLS_COMPRESSION_GET +# endif + +/* gnutls_mac_get_nonce_size was added in GnuTLS 3.2.0, but was + exported only since 3.3.0. */ +# if GNUTLS_VERSION_NUMBER >= 0x030300 +# define HAVE_GNUTLS_MAC_GET_NONCE_SIZE +# endif + +# if GNUTLS_VERSION_NUMBER >= 0x030501 +# define HAVE_GNUTLS_EXT_GET_NAME +# endif /* Although AEAD support started in GnuTLS 3.4.0 and works in 3.5.14, it was broken through at least GnuTLS 3.4.10; see: - https://lists.gnu.org/archive/html/emacs-devel/2017-07/msg00992.html + https://lists.gnu.org/r/emacs-devel/2017-07/msg00992.html The relevant fix seems to have been made in GnuTLS 3.5.1; see: https://gitlab.com/gnutls/gnutls/commit/568935848dd6b82b9315d8b6c529d00e2605e03d So, require 3.5.1. */ -#if 0x030501 <= GNUTLS_VERSION_NUMBER -# define HAVE_GNUTLS_AEAD -#endif - -#ifdef HAVE_GNUTLS +# if GNUTLS_VERSION_NUMBER >= 0x030501 +# define HAVE_GNUTLS_AEAD +# endif # ifdef WINDOWSNT # include <windows.h> +# include "w32common.h" # include "w32.h" # endif -static bool emacs_gnutls_handle_error (gnutls_session_t, int); +static int emacs_gnutls_handle_error (gnutls_session_t, int); static bool gnutls_global_initialized; @@ -134,6 +167,8 @@ DEF_DLL_FN (int, gnutls_x509_crt_check_hostname, DEF_DLL_FN (int, gnutls_x509_crt_check_issuer, (gnutls_x509_crt_t, gnutls_x509_crt_t)); DEF_DLL_FN (void, gnutls_x509_crt_deinit, (gnutls_x509_crt_t)); +DEF_DLL_FN (int, gnutls_x509_crt_export, + (gnutls_x509_crt_t, gnutls_x509_crt_fmt_t, void *, size_t *)); DEF_DLL_FN (int, gnutls_x509_crt_import, (gnutls_x509_crt_t, const gnutls_datum_t *, gnutls_x509_crt_fmt_t)); @@ -155,6 +190,9 @@ DEF_DLL_FN (int, gnutls_x509_crt_get_dn, (gnutls_x509_crt_t, char *, size_t *)); DEF_DLL_FN (int, gnutls_x509_crt_get_pk_algorithm, (gnutls_x509_crt_t, unsigned int *)); +DEF_DLL_FN (int, gnutls_x509_crt_print, + (gnutls_x509_crt_t, gnutls_certificate_print_formats_t, + gnutls_datum_t *)); DEF_DLL_FN (const char *, gnutls_pk_algorithm_get_name, (gnutls_pk_algorithm_t)); DEF_DLL_FN (int, gnutls_pk_bits_to_sec_param, @@ -183,19 +221,33 @@ DEF_DLL_FN (const char *, gnutls_cipher_get_name, (gnutls_cipher_algorithm_t)); DEF_DLL_FN (gnutls_mac_algorithm_t, gnutls_mac_get, (gnutls_session_t)); DEF_DLL_FN (const char *, gnutls_mac_get_name, (gnutls_mac_algorithm_t)); +# ifdef HAVE_GNUTLS_COMPRESSION_GET +DEF_DLL_FN (gnutls_compression_method_t, gnutls_compression_get, + (gnutls_session_t)); +DEF_DLL_FN (const char *, gnutls_compression_get_name, + (gnutls_compression_method_t)); +# endif +DEF_DLL_FN (unsigned, gnutls_safe_renegotiation_status, (gnutls_session_t)); # ifdef HAVE_GNUTLS3 -DEF_DLL_FN (int, gnutls_rnd, (gnutls_rnd_level_t, void *, size_t)); DEF_DLL_FN (const gnutls_mac_algorithm_t *, gnutls_mac_list, (void)); +# ifdef HAVE_GNUTLS_MAC_GET_NONCE_SIZE DEF_DLL_FN (size_t, gnutls_mac_get_nonce_size, (gnutls_mac_algorithm_t)); +# endif DEF_DLL_FN (size_t, gnutls_mac_get_key_size, (gnutls_mac_algorithm_t)); +# ifdef HAVE_GNUTLS_DIGEST_LIST DEF_DLL_FN (const gnutls_digest_algorithm_t *, gnutls_digest_list, (void)); DEF_DLL_FN (const char *, gnutls_digest_get_name, (gnutls_digest_algorithm_t)); +# endif DEF_DLL_FN (gnutls_cipher_algorithm_t *, gnutls_cipher_list, (void)); +# ifdef HAVE_GNUTLS_CIPHER_GET_IV_SIZE DEF_DLL_FN (int, gnutls_cipher_get_iv_size, (gnutls_cipher_algorithm_t)); +# endif DEF_DLL_FN (size_t, gnutls_cipher_get_key_size, (gnutls_cipher_algorithm_t)); DEF_DLL_FN (int, gnutls_cipher_get_block_size, (gnutls_cipher_algorithm_t)); +# ifdef HAVE_GNUTLS_CIPHER_GET_TAG_SIZE DEF_DLL_FN (int, gnutls_cipher_get_tag_size, (gnutls_cipher_algorithm_t)); +# endif DEF_DLL_FN (int, gnutls_cipher_init, (gnutls_cipher_hd_t *, gnutls_cipher_algorithm_t, const gnutls_datum_t *, const gnutls_datum_t *)); @@ -217,6 +269,9 @@ DEF_DLL_FN (int, gnutls_aead_cipher_decrypt, (gnutls_aead_cipher_hd_t, const void *, size_t, const void *, size_t, size_t, const void *, size_t, void *, size_t *)); # endif +# ifdef HAVE_GNUTLS_ETM_STATUS +DEF_DLL_FN (unsigned, gnutls_session_etm_status, (gnutls_session_t)); +# endif DEF_DLL_FN (int, gnutls_hmac_init, (gnutls_hmac_hd_t *, gnutls_mac_algorithm_t, const void *, size_t)); DEF_DLL_FN (int, gnutls_hmac_get_len, (gnutls_mac_algorithm_t)); @@ -229,8 +284,12 @@ DEF_DLL_FN (int, gnutls_hash_get_len, (gnutls_digest_algorithm_t)); DEF_DLL_FN (int, gnutls_hash, (gnutls_hash_hd_t, const void *, size_t)); DEF_DLL_FN (void, gnutls_hash_deinit, (gnutls_hash_hd_t, void *)); DEF_DLL_FN (void, gnutls_hash_output, (gnutls_hash_hd_t, void *)); +# ifdef HAVE_GNUTLS_EXT_GET_NAME +DEF_DLL_FN (const char *, gnutls_ext_get_name, (unsigned int)); +# endif # endif /* HAVE_GNUTLS3 */ +static gnutls_free_function *gnutls_free_func; static bool init_gnutls_functions (void) @@ -286,6 +345,7 @@ init_gnutls_functions (void) LOAD_DLL_FN (library, gnutls_x509_crt_check_hostname); LOAD_DLL_FN (library, gnutls_x509_crt_check_issuer); LOAD_DLL_FN (library, gnutls_x509_crt_deinit); + LOAD_DLL_FN (library, gnutls_x509_crt_export); LOAD_DLL_FN (library, gnutls_x509_crt_import); LOAD_DLL_FN (library, gnutls_x509_crt_init); LOAD_DLL_FN (library, gnutls_x509_crt_get_fingerprint); @@ -296,6 +356,7 @@ init_gnutls_functions (void) LOAD_DLL_FN (library, gnutls_x509_crt_get_expiration_time); LOAD_DLL_FN (library, gnutls_x509_crt_get_dn); LOAD_DLL_FN (library, gnutls_x509_crt_get_pk_algorithm); + LOAD_DLL_FN (library, gnutls_x509_crt_print); LOAD_DLL_FN (library, gnutls_pk_algorithm_get_name); LOAD_DLL_FN (library, gnutls_pk_bits_to_sec_param); LOAD_DLL_FN (library, gnutls_x509_crt_get_issuer_unique_id); @@ -313,18 +374,30 @@ init_gnutls_functions (void) LOAD_DLL_FN (library, gnutls_cipher_get_name); LOAD_DLL_FN (library, gnutls_mac_get); LOAD_DLL_FN (library, gnutls_mac_get_name); +# ifdef HAVE_GNUTLS_COMPRESSION_GET + LOAD_DLL_FN (library, gnutls_compression_get); + LOAD_DLL_FN (library, gnutls_compression_get_name); +# endif + LOAD_DLL_FN (library, gnutls_safe_renegotiation_status); # ifdef HAVE_GNUTLS3 - LOAD_DLL_FN (library, gnutls_rnd); LOAD_DLL_FN (library, gnutls_mac_list); +# ifdef HAVE_GNUTLS_MAC_GET_NONCE_SIZE LOAD_DLL_FN (library, gnutls_mac_get_nonce_size); +# endif LOAD_DLL_FN (library, gnutls_mac_get_key_size); +# ifdef HAVE_GNUTLS_DIGEST_LIST LOAD_DLL_FN (library, gnutls_digest_list); LOAD_DLL_FN (library, gnutls_digest_get_name); +# endif LOAD_DLL_FN (library, gnutls_cipher_list); +# ifdef HAVE_GNUTLS_CIPHER_GET_IV_SIZE LOAD_DLL_FN (library, gnutls_cipher_get_iv_size); +# endif LOAD_DLL_FN (library, gnutls_cipher_get_key_size); LOAD_DLL_FN (library, gnutls_cipher_get_block_size); +# ifdef HAVE_GNUTLS_CIPHER_GET_TAG_SIZE LOAD_DLL_FN (library, gnutls_cipher_get_tag_size); +# endif LOAD_DLL_FN (library, gnutls_cipher_init); LOAD_DLL_FN (library, gnutls_cipher_set_iv); LOAD_DLL_FN (library, gnutls_cipher_encrypt2); @@ -336,6 +409,9 @@ init_gnutls_functions (void) LOAD_DLL_FN (library, gnutls_aead_cipher_encrypt); LOAD_DLL_FN (library, gnutls_aead_cipher_decrypt); # endif +# ifdef HAVE_GNUTLS_ETM_STATUS + LOAD_DLL_FN (library, gnutls_session_etm_status); +# endif LOAD_DLL_FN (library, gnutls_hmac_init); LOAD_DLL_FN (library, gnutls_hmac_get_len); LOAD_DLL_FN (library, gnutls_hmac); @@ -346,10 +422,19 @@ init_gnutls_functions (void) LOAD_DLL_FN (library, gnutls_hash); LOAD_DLL_FN (library, gnutls_hash_deinit); LOAD_DLL_FN (library, gnutls_hash_output); +# ifdef HAVE_GNUTLS_EXT_GET_NAME + LOAD_DLL_FN (library, gnutls_ext_get_name); +# endif # endif /* HAVE_GNUTLS3 */ - max_log_level = global_gnutls_log_level; + /* gnutls_free is a variable inside GnuTLS, whose value is the + "free" function. So it needs special handling. */ + gnutls_free_func = (gnutls_free_function *) GetProcAddress (library, + "gnutls_free"); + if (!gnutls_free_func) + return false; + max_log_level = clip_to_bounds (INT_MIN, global_gnutls_log_level, INT_MAX); { Lisp_Object name = CAR_SAFE (Fget (Qgnutls, QCloaded_from)); GNUTLS_LOG2 (1, max_log_level, "GnuTLS library loaded:", @@ -391,6 +476,11 @@ init_gnutls_functions (void) # define gnutls_kx_get_name fn_gnutls_kx_get_name # define gnutls_mac_get fn_gnutls_mac_get # define gnutls_mac_get_name fn_gnutls_mac_get_name +# ifdef HAVE_GNUTLS_COMPRESSION_GET +# define gnutls_compression_get fn_gnutls_compression_get +# define gnutls_compression_get_name fn_gnutls_compression_get_name +# endif +# define gnutls_safe_renegotiation_status fn_gnutls_safe_renegotiation_status # define gnutls_pk_algorithm_get_name fn_gnutls_pk_algorithm_get_name # define gnutls_pk_bits_to_sec_param fn_gnutls_pk_bits_to_sec_param # define gnutls_priority_set_direct fn_gnutls_priority_set_direct @@ -410,6 +500,7 @@ init_gnutls_functions (void) # define gnutls_x509_crt_check_hostname fn_gnutls_x509_crt_check_hostname # define gnutls_x509_crt_check_issuer fn_gnutls_x509_crt_check_issuer # define gnutls_x509_crt_deinit fn_gnutls_x509_crt_deinit +# define gnutls_x509_crt_export fn_gnutls_x509_crt_export # define gnutls_x509_crt_get_activation_time fn_gnutls_x509_crt_get_activation_time # define gnutls_x509_crt_get_dn fn_gnutls_x509_crt_get_dn # define gnutls_x509_crt_get_expiration_time fn_gnutls_x509_crt_get_expiration_time @@ -418,6 +509,7 @@ init_gnutls_functions (void) # define gnutls_x509_crt_get_issuer_unique_id fn_gnutls_x509_crt_get_issuer_unique_id # define gnutls_x509_crt_get_key_id fn_gnutls_x509_crt_get_key_id # define gnutls_x509_crt_get_pk_algorithm fn_gnutls_x509_crt_get_pk_algorithm +# define gnutls_x509_crt_print fn_gnutls_x509_crt_print # define gnutls_x509_crt_get_serial fn_gnutls_x509_crt_get_serial # define gnutls_x509_crt_get_signature_algorithm fn_gnutls_x509_crt_get_signature_algorithm # define gnutls_x509_crt_get_subject_unique_id fn_gnutls_x509_crt_get_subject_unique_id @@ -425,27 +517,37 @@ init_gnutls_functions (void) # define gnutls_x509_crt_import fn_gnutls_x509_crt_import # define gnutls_x509_crt_init fn_gnutls_x509_crt_init # ifdef HAVE_GNUTLS3 -# define gnutls_rnd fn_gnutls_rnd # define gnutls_mac_list fn_gnutls_mac_list -# define gnutls_mac_get_nonce_size fn_gnutls_mac_get_nonce_size +# ifdef HAVE_GNUTLS_MAC_GET_NONCE_SIZE +# define gnutls_mac_get_nonce_size fn_gnutls_mac_get_nonce_size +# endif # define gnutls_mac_get_key_size fn_gnutls_mac_get_key_size -# define gnutls_digest_list fn_gnutls_digest_list -# define gnutls_digest_get_name fn_gnutls_digest_get_name +# ifdef HAVE_GNUTLS_DIGEST_LIST +# define gnutls_digest_list fn_gnutls_digest_list +# define gnutls_digest_get_name fn_gnutls_digest_get_name +# endif # define gnutls_cipher_list fn_gnutls_cipher_list -# define gnutls_cipher_get_iv_size fn_gnutls_cipher_get_iv_size +# ifdef HAVE_GNUTLS_CIPHER_GET_IV_SIZE +# define gnutls_cipher_get_iv_size fn_gnutls_cipher_get_iv_size +# endif # define gnutls_cipher_get_key_size fn_gnutls_cipher_get_key_size # define gnutls_cipher_get_block_size fn_gnutls_cipher_get_block_size -# define gnutls_cipher_get_tag_size fn_gnutls_cipher_get_tag_size +# ifdef HAVE_GNUTLS_CIPHER_GET_TAG_SIZE +# define gnutls_cipher_get_tag_size fn_gnutls_cipher_get_tag_size +# endif # define gnutls_cipher_init fn_gnutls_cipher_init # define gnutls_cipher_set_iv fn_gnutls_cipher_set_iv # define gnutls_cipher_encrypt2 fn_gnutls_cipher_encrypt2 # define gnutls_cipher_decrypt2 fn_gnutls_cipher_decrypt2 # define gnutls_cipher_deinit fn_gnutls_cipher_deinit # ifdef HAVE_GNUTLS_AEAD -# define gnutls_aead_cipher_encrypt fn_gnutls_aead_cipher_encrypt -# define gnutls_aead_cipher_decrypt fn_gnutls_aead_cipher_decrypt -# define gnutls_aead_cipher_init fn_gnutls_aead_cipher_init -# define gnutls_aead_cipher_deinit fn_gnutls_aead_cipher_deinit +# define gnutls_aead_cipher_encrypt fn_gnutls_aead_cipher_encrypt +# define gnutls_aead_cipher_decrypt fn_gnutls_aead_cipher_decrypt +# define gnutls_aead_cipher_init fn_gnutls_aead_cipher_init +# define gnutls_aead_cipher_deinit fn_gnutls_aead_cipher_deinit +# endif +# ifdef HAVE_GNUTLS_ETM_STATUS +# define gnutls_session_etm_status fn_gnutls_session_etm_status # endif # define gnutls_hmac_init fn_gnutls_hmac_init # define gnutls_hmac_get_len fn_gnutls_hmac_get_len @@ -457,15 +559,16 @@ init_gnutls_functions (void) # define gnutls_hash fn_gnutls_hash # define gnutls_hash_deinit fn_gnutls_hash_deinit # define gnutls_hash_output fn_gnutls_hash_output +# ifdef HAVE_GNUTLS_EXT_GET_NAME +# define gnutls_ext_get_name fn_gnutls_ext_get_name +# endif # endif /* HAVE_GNUTLS3 */ -/* This wrapper is called from fns.c, which doesn't know about the - LOAD_DLL_FN stuff above. */ -int -w32_gnutls_rnd (gnutls_rnd_level_t level, void *data, size_t len) -{ - return gnutls_rnd (level, data, len); -} +/* gnutls_free_func is a data pointer to a variable which holds an + address of a function. We use #undef because MinGW64 defines + gnutls_free as a macro as well in the GnuTLS headers. */ +# undef gnutls_free +# define gnutls_free (*gnutls_free_func) # endif /* WINDOWSNT */ @@ -513,6 +616,9 @@ gnutls_try_handshake (struct Lisp_Process *proc) gnutls_session_t state = proc->gnutls_state; int ret; bool non_blocking = proc->is_non_blocking_client; + /* Sleep for ten milliseconds when busy-looping in + gnutls_handshake. */ + struct timespec delay = { 0, 1000 * 1000 * 10 }; if (proc->gnutls_complete_negotiation_p) non_blocking = false; @@ -520,15 +626,15 @@ gnutls_try_handshake (struct Lisp_Process *proc) if (non_blocking) proc->gnutls_p = true; - do + while ((ret = gnutls_handshake (state)) < 0) { - ret = gnutls_handshake (state); - emacs_gnutls_handle_error (state, ret); + if (emacs_gnutls_handle_error (state, ret) == 0) /* fatal */ + break; maybe_quit (); + if (non_blocking && ret != GNUTLS_E_INTERRUPTED) + break; + nanosleep (&delay, NULL); } - while (ret < 0 - && gnutls_error_is_fatal (ret) == 0 - && ! non_blocking); proc->gnutls_initstage = GNUTLS_STAGE_HANDSHAKE_TRIED; @@ -623,8 +729,6 @@ emacs_gnutls_transport_set_errno (gnutls_session_t state, int err) ptrdiff_t emacs_gnutls_write (struct Lisp_Process *proc, const char *buf, ptrdiff_t nbyte) { - ssize_t rtnval = 0; - ptrdiff_t bytes_written; gnutls_session_t state = proc->gnutls_state; if (proc->gnutls_initstage != GNUTLS_STAGE_READY) @@ -633,25 +737,19 @@ emacs_gnutls_write (struct Lisp_Process *proc, const char *buf, ptrdiff_t nbyte) return 0; } - bytes_written = 0; + ptrdiff_t bytes_written = 0; while (nbyte > 0) { - rtnval = gnutls_record_send (state, buf, nbyte); + ssize_t rtnval; + do + rtnval = gnutls_record_send (state, buf, nbyte); + while (rtnval == GNUTLS_E_INTERRUPTED); if (rtnval < 0) { - if (rtnval == GNUTLS_E_INTERRUPTED) - continue; - else - { - /* If we get GNUTLS_E_AGAIN, then set errno - appropriately so that send_process retries the - correct way instead of erroring out. */ - if (rtnval == GNUTLS_E_AGAIN) - errno = EAGAIN; - break; - } + emacs_gnutls_handle_error (state, rtnval); + break; } buf += rtnval; @@ -659,14 +757,12 @@ emacs_gnutls_write (struct Lisp_Process *proc, const char *buf, ptrdiff_t nbyte) bytes_written += rtnval; } - emacs_gnutls_handle_error (state, rtnval); return (bytes_written); } ptrdiff_t emacs_gnutls_read (struct Lisp_Process *proc, char *buf, ptrdiff_t nbyte) { - ssize_t rtnval; gnutls_session_t state = proc->gnutls_state; if (proc->gnutls_initstage != GNUTLS_STAGE_READY) @@ -675,19 +771,18 @@ emacs_gnutls_read (struct Lisp_Process *proc, char *buf, ptrdiff_t nbyte) return -1; } - rtnval = gnutls_record_recv (state, buf, nbyte); + ssize_t rtnval; + do + rtnval = gnutls_record_recv (state, buf, nbyte); + while (rtnval == GNUTLS_E_INTERRUPTED); + if (rtnval >= 0) return rtnval; else if (rtnval == GNUTLS_E_UNEXPECTED_PACKET_LENGTH) /* The peer closed the connection. */ return 0; - else if (emacs_gnutls_handle_error (state, rtnval)) - /* non-fatal error */ - return -1; - else { - /* a fatal error occurred */ - return 0; - } + else + return emacs_gnutls_handle_error (state, rtnval); } static char const * @@ -698,25 +793,25 @@ emacs_gnutls_strerror (int err) } /* Report a GnuTLS error to the user. - Return true if the error code was successfully handled. */ -static bool + SESSION is the GnuTLS session, ERR is the (negative) GnuTLS error code. + Return 0 if the error was fatal, -1 (setting errno) otherwise so + that the caller can notice the error and attempt a repair. */ +static int emacs_gnutls_handle_error (gnutls_session_t session, int err) { - int max_log_level = 0; - - bool ret; + int ret; /* TODO: use a Lisp_Object generated by gnutls_make_error? */ - if (err >= 0) - return 1; check_memory_full (err); - max_log_level = global_gnutls_log_level; + int max_log_level + = clip_to_bounds (INT_MIN, global_gnutls_log_level, INT_MAX); /* TODO: use gnutls-error-fatalp and gnutls-error-string. */ char const *str = emacs_gnutls_strerror (err); + int errnum = EINVAL; if (gnutls_error_is_fatal (err)) { @@ -730,11 +825,11 @@ emacs_gnutls_handle_error (gnutls_session_t session, int err) # endif GNUTLS_LOG2 (level, max_log_level, "fatal error:", str); - ret = false; + ret = 0; } else { - ret = true; + ret = -1; switch (err) { @@ -750,6 +845,26 @@ emacs_gnutls_handle_error (gnutls_session_t session, int err) "non-fatal error:", str); } + + switch (err) + { + case GNUTLS_E_AGAIN: + errnum = EAGAIN; + break; + +# ifdef EMSGSIZE + case GNUTLS_E_LARGE_PACKET: + case GNUTLS_E_PUSH_ERROR: + errnum = EMSGSIZE; + break; +# endif + +# if defined HAVE_GNUTLS3 && defined ECONNRESET + case GNUTLS_E_PREMATURE_TERMINATION: + errnum = ECONNRESET; + break; +# endif + } } if (err == GNUTLS_E_WARNING_ALERT_RECEIVED @@ -763,11 +878,13 @@ emacs_gnutls_handle_error (gnutls_session_t session, int err) GNUTLS_LOG2 (level, max_log_level, "Received alert: ", str); } + + errno = errnum; return ret; } /* convert an integer error to a Lisp_Object; it will be either a - known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or + known symbol like 'gnutls_e_interrupted' and 'gnutls_e_again' or simply the integer value of the error. GNUTLS_E_SUCCESS is mapped to Qt. */ static Lisp_Object @@ -786,7 +903,20 @@ gnutls_make_error (int err) } check_memory_full (err); - return make_number (err); + return make_fixnum (err); +} + +static void +gnutls_deinit_certificates (struct Lisp_Process *p) +{ + if (! p->gnutls_certificates) + return; + + for (int i = 0; i < p->gnutls_certificates_length; i++) + gnutls_x509_crt_deinit (p->gnutls_certificates[i]); + + xfree (p->gnutls_certificates); + p->gnutls_certificates = NULL; } Lisp_Object @@ -823,6 +953,9 @@ emacs_gnutls_deinit (Lisp_Object proc) GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT - 1; } + if (XPROCESS (proc)->gnutls_certificates) + gnutls_deinit_certificates (XPROCESS (proc)); + XPROCESS (proc)->gnutls_p = false; return Qt; } @@ -847,7 +980,7 @@ See also `gnutls-boot'. */) { CHECK_PROCESS (proc); - return make_number (GNUTLS_INITSTAGE (proc)); + return make_fixnum (GNUTLS_INITSTAGE (proc)); } DEFUN ("gnutls-errorp", Fgnutls_errorp, Sgnutls_errorp, 1, 1, 0, @@ -887,10 +1020,10 @@ Usage: (gnutls-error-fatalp ERROR) */) } } - if (! TYPE_RANGED_INTEGERP (int, err)) + if (! TYPE_RANGED_FIXNUMP (int, err)) error ("Not an error symbol or code"); - if (0 == gnutls_error_is_fatal (XINT (err))) + if (0 == gnutls_error_is_fatal (XFIXNUM (err))) return Qnil; return Qt; @@ -919,10 +1052,10 @@ usage: (gnutls-error-string ERROR) */) } } - if (! TYPE_RANGED_INTEGERP (int, err)) + if (! TYPE_RANGED_FIXNUMP (int, err)) return build_string ("Not an error symbol or code"); - return build_string (emacs_gnutls_strerror (XINT (err))); + return build_string (emacs_gnutls_strerror (XFIXNUM (err))); } DEFUN ("gnutls-deinit", Fgnutls_deinit, Sgnutls_deinit, 1, 1, 0, @@ -954,7 +1087,35 @@ gnutls_hex_string (unsigned char *buf, ptrdiff_t buf_size, const char *prefix) } static Lisp_Object -gnutls_certificate_details (gnutls_x509_crt_t cert) +emacs_gnutls_certificate_export_pem (gnutls_x509_crt_t cert) +{ + size_t size = 0; + int err = gnutls_x509_crt_export (cert, GNUTLS_X509_FMT_PEM, NULL, &size); + check_memory_full (err); + + if (err == GNUTLS_E_SHORT_MEMORY_BUFFER) + { + USE_SAFE_ALLOCA; + char *buf = SAFE_ALLOCA (size); + err = gnutls_x509_crt_export (cert, GNUTLS_X509_FMT_PEM, buf, &size); + check_memory_full (err); + + if (err < GNUTLS_E_SUCCESS) + error ("GnuTLS certificate export error: %s", + emacs_gnutls_strerror (err)); + + Lisp_Object result = build_string (buf); + SAFE_FREE (); + return result; + } + else if (err < GNUTLS_E_SUCCESS) + error ("GnuTLS certificate export error: %s", emacs_gnutls_strerror (err)); + + return Qnil; +} + +static Lisp_Object +emacs_gnutls_certificate_details (gnutls_x509_crt_t cert) { Lisp_Object res = Qnil; int err; @@ -966,7 +1127,7 @@ gnutls_certificate_details (gnutls_x509_crt_t cert) check_memory_full (version); if (version >= GNUTLS_E_SUCCESS) res = nconc2 (res, list2 (intern (":version"), - make_number (version))); + make_fixnum (version))); } /* Serial. */ @@ -1122,6 +1283,10 @@ gnutls_certificate_details (gnutls_x509_crt_t cert) xfree (buf); } + /* PEM */ + res = nconc2 (res, list2 (intern (":pem"), + emacs_gnutls_certificate_export_pem(cert))); + return res; } @@ -1159,14 +1324,45 @@ DEFUN ("gnutls-peer-status-warning-describe", Fgnutls_peer_status_warning_descri if (EQ (status_symbol, intern (":no-host-match"))) return build_string ("certificate host does not match hostname"); + if (EQ (status_symbol, intern (":signature-failure"))) + return build_string ("certificate signature could not be verified"); + + if (EQ (status_symbol, intern (":revocation-data-superseded"))) + return build_string ("certificate revocation data are old and have been " + "superseded"); + + if (EQ (status_symbol, intern (":revocation-data-issued-in-future"))) + return build_string ("certificate revocation data have a future issue date"); + + if (EQ (status_symbol, intern (":signer-constraints-failure"))) + return build_string ("certificate signer constraints were violated"); + + if (EQ (status_symbol, intern (":purpose-mismatch"))) + return build_string ("certificate does not match the intended purpose"); + + if (EQ (status_symbol, intern (":missing-ocsp-status"))) + return build_string ("certificate requires the server to send a OCSP " + "certificate status, but no status was received"); + + if (EQ (status_symbol, intern (":invalid-ocsp-status"))) + return build_string ("the received OCSP certificate status is invalid"); + return Qnil; } DEFUN ("gnutls-peer-status", Fgnutls_peer_status, Sgnutls_peer_status, 1, 1, 0, doc: /* Describe a GnuTLS PROC peer certificate and any warnings about it. + The return value is a property list with top-level keys :warnings and -:certificate. The :warnings entry is a list of symbols you can describe with -`gnutls-peer-status-warning-describe'. */) +:certificates. + +The :warnings entry is a list of symbols you can get a description of +with `gnutls-peer-status-warning-describe', and :certificates is the +certificate chain for the connection, with the host certificate +first, and intermediary certificates (if any) following it. + +In addition, for backwards compatibility, the host certificate is also +returned as the :certificate entry. */) (Lisp_Object proc) { Lisp_Object warnings = Qnil, result = Qnil; @@ -1202,15 +1398,44 @@ The return value is a property list with top-level keys :warnings and if (verification & GNUTLS_CERT_EXPIRED) warnings = Fcons (intern (":expired"), warnings); +# if GNUTLS_VERSION_NUMBER >= 0x030100 + if (verification & GNUTLS_CERT_SIGNATURE_FAILURE) + warnings = Fcons (intern (":signature-failure"), warnings); + +# if GNUTLS_VERSION_NUMBER >= 0x030114 + if (verification & GNUTLS_CERT_REVOCATION_DATA_SUPERSEDED) + warnings = Fcons (intern (":revocation-data-superseded"), warnings); + + if (verification & GNUTLS_CERT_REVOCATION_DATA_ISSUED_IN_FUTURE) + warnings = Fcons (intern (":revocation-data-issued-in-future"), warnings); + + if (verification & GNUTLS_CERT_SIGNER_CONSTRAINTS_FAILURE) + warnings = Fcons (intern (":signer-constraints-failure"), warnings); + +# if GNUTLS_VERSION_NUMBER >= 0x030400 + if (verification & GNUTLS_CERT_PURPOSE_MISMATCH) + warnings = Fcons (intern (":purpose-mismatch"), warnings); + +# if GNUTLS_VERSION_NUMBER >= 0x030501 + if (verification & GNUTLS_CERT_MISSING_OCSP_STATUS) + warnings = Fcons (intern (":missing-ocsp-status"), warnings); + + if (verification & GNUTLS_CERT_INVALID_OCSP_STATUS) + warnings = Fcons (intern (":invalid-ocsp-status"), warnings); +# endif +# endif +# endif +# endif + if (XPROCESS (proc)->gnutls_extra_peer_verification & CERTIFICATE_NOT_MATCHING) warnings = Fcons (intern (":no-host-match"), warnings); /* This could get called in the INIT stage, when the certificate is not yet set. */ - if (XPROCESS (proc)->gnutls_certificate != NULL && - gnutls_x509_crt_check_issuer(XPROCESS (proc)->gnutls_certificate, - XPROCESS (proc)->gnutls_certificate)) + if (XPROCESS (proc)->gnutls_certificates != NULL && + gnutls_x509_crt_check_issuer(XPROCESS (proc)->gnutls_certificates[0], + XPROCESS (proc)->gnutls_certificates[0])) warnings = Fcons (intern (":self-signed"), warnings); if (!NILP (warnings)) @@ -1218,10 +1443,21 @@ The return value is a property list with top-level keys :warnings and /* This could get called in the INIT stage, when the certificate is not yet set. */ - if (XPROCESS (proc)->gnutls_certificate != NULL) - result = nconc2 (result, list2 - (intern (":certificate"), - gnutls_certificate_details (XPROCESS (proc)->gnutls_certificate))); + if (XPROCESS (proc)->gnutls_certificates != NULL) + { + Lisp_Object certs = Qnil; + + /* Return all the certificates in a list. */ + for (int i = 0; i < XPROCESS (proc)->gnutls_certificates_length; i++) + certs = nconc2 (certs, list1 (emacs_gnutls_certificate_details + (XPROCESS (proc)->gnutls_certificates[i]))); + + result = nconc2 (result, list2 (intern (":certificates"), certs)); + + /* Return the host certificate in its own element for + compatibility reasons. */ + result = nconc2 (result, list2 (intern (":certificate"), Fcar (certs))); + } state = XPROCESS (proc)->gnutls_state; @@ -1231,7 +1467,7 @@ The return value is a property list with top-level keys :warnings and check_memory_full (bits); if (bits > 0) result = nconc2 (result, list2 (intern (":diffie-hellman-prime-bits"), - make_number (bits))); + make_fixnum (bits))); } /* Key exchange. */ @@ -1241,10 +1477,10 @@ The return value is a property list with top-level keys :warnings and (gnutls_kx_get (state))))); /* Protocol name. */ + gnutls_protocol_t proto = gnutls_protocol_get_version (state); result = nconc2 (result, list2 (intern (":protocol"), - build_string (gnutls_protocol_get_name - (gnutls_protocol_get_version (state))))); + build_string (gnutls_protocol_get_name (proto)))); /* Cipher name. */ result = nconc2 @@ -1258,14 +1494,34 @@ The return value is a property list with top-level keys :warnings and build_string (gnutls_mac_get_name (gnutls_mac_get (state))))); + /* Compression name. */ +# ifdef HAVE_GNUTLS_COMPRESSION_GET + result = nconc2 + (result, list2 (intern (":compression"), + build_string (gnutls_compression_get_name + (gnutls_compression_get (state))))); +# endif + + /* Encrypt-then-MAC. */ +# ifdef HAVE_GNUTLS_ETM_STATUS + result = nconc2 + (result, list2 (intern (":encrypt-then-mac"), + gnutls_session_etm_status (state) ? Qt : Qnil)); +# endif + + /* Renegotiation Indication */ + if (proto <= GNUTLS_TLS1_2) + result = nconc2 + (result, list2 (intern (":safe-renegotiation"), + gnutls_safe_renegotiation_status (state) ? Qt : Qnil)); return result; } /* Initialize global GnuTLS state to defaults. - Call `gnutls-global-deinit' when GnuTLS usage is no longer needed. + Call 'gnutls-global-deinit' when GnuTLS usage is no longer needed. Return zero on success. */ -Lisp_Object +static Lisp_Object emacs_gnutls_global_init (void) { int ret = GNUTLS_E_SUCCESS; @@ -1294,7 +1550,7 @@ gnutls_ip_address_p (char *string) # if 0 /* Deinitialize global GnuTLS state. - See also `gnutls-global-init'. */ + See also 'gnutls-global-init'. */ static Lisp_Object emacs_gnutls_global_deinit (void) { @@ -1319,6 +1575,52 @@ boot_error (struct Lisp_Process *p, const char *m, ...) va_end (ap); } +DEFUN ("gnutls-format-certificate", Fgnutls_format_certificate, + Sgnutls_format_certificate, 1, 1, 0, + doc: /* Format a X.509 certificate to a string. + +Given a PEM-encoded X.509 certificate CERT, returns a human-readable +string representation. */) + (Lisp_Object cert) +{ + CHECK_STRING (cert); + + int err; + gnutls_x509_crt_t crt; + + err = gnutls_x509_crt_init (&crt); + check_memory_full (err); + if (err < GNUTLS_E_SUCCESS) + error ("gnutls-format-certificate error: %s", emacs_gnutls_strerror (err)); + + gnutls_datum_t crt_data = { SDATA (cert), strlen (SSDATA (cert)) }; + err = gnutls_x509_crt_import (crt, &crt_data, GNUTLS_X509_FMT_PEM); + check_memory_full (err); + if (err < GNUTLS_E_SUCCESS) + { + gnutls_x509_crt_deinit (crt); + error ("gnutls-format-certificate error: %s", + emacs_gnutls_strerror (err)); + } + + gnutls_datum_t out; + err = gnutls_x509_crt_print (crt, GNUTLS_CRT_PRINT_FULL, &out); + check_memory_full (err); + if (err < GNUTLS_E_SUCCESS) + { + gnutls_x509_crt_deinit (crt); + error ("gnutls-format-certificate error: %s", + emacs_gnutls_strerror (err)); + } + + Lisp_Object result = make_string_from_bytes ((char *) out.data, out.size, + out.size); + gnutls_free (out.data); + gnutls_x509_crt_deinit (crt); + + return result; +} + Lisp_Object gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist) { @@ -1333,10 +1635,10 @@ gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist) char *c_hostname; if (NILP (proplist)) - proplist = Fcdr (Fplist_get (p->childp, QCtls_parameters)); + proplist = Fcdr (plist_get (p->childp, QCtls_parameters)); - verify_error = Fplist_get (proplist, QCverify_error); - hostname = Fplist_get (proplist, QChostname); + verify_error = plist_get (proplist, QCverify_error); + hostname = plist_get (proplist, QChostname); if (EQ (verify_error, Qt)) verify_error_all = true; @@ -1364,9 +1666,9 @@ gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist) if (ret < GNUTLS_E_SUCCESS) return gnutls_make_error (ret); - XPROCESS (proc)->gnutls_peer_verification = peer_verification; + p->gnutls_peer_verification = peer_verification; - warnings = Fplist_get (Fgnutls_peer_status (proc), intern (":warnings")); + warnings = plist_get (Fgnutls_peer_status (proc), intern (":warnings")); if (!NILP (warnings)) { for (Lisp_Object tail = warnings; CONSP (tail); tail = XCDR (tail)) @@ -1401,49 +1703,60 @@ gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist) can be easily extended to work with openpgp keys as well. */ if (gnutls_certificate_type_get (state) == GNUTLS_CRT_X509) { - gnutls_x509_crt_t gnutls_verify_cert; - const gnutls_datum_t *gnutls_verify_cert_list; - unsigned int gnutls_verify_cert_list_size; + const gnutls_datum_t *cert_list; + unsigned int cert_list_length; + int failed_import = 0; - ret = gnutls_x509_crt_init (&gnutls_verify_cert); - if (ret < GNUTLS_E_SUCCESS) - return gnutls_make_error (ret); - - gnutls_verify_cert_list - = gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size); + cert_list = gnutls_certificate_get_peers (state, &cert_list_length); - if (gnutls_verify_cert_list == NULL) + if (cert_list == NULL) { - gnutls_x509_crt_deinit (gnutls_verify_cert); emacs_gnutls_deinit (proc); boot_error (p, "No x509 certificate was found\n"); return Qnil; } - /* Check only the first certificate in the given chain. */ - ret = gnutls_x509_crt_import (gnutls_verify_cert, - &gnutls_verify_cert_list[0], - GNUTLS_X509_FMT_DER); + /* Check only the first certificate in the given chain, but + store them all. */ + p->gnutls_certificates = + xmalloc (cert_list_length * sizeof (gnutls_x509_crt_t)); + p->gnutls_certificates_length = cert_list_length; - if (ret < GNUTLS_E_SUCCESS) + for (int i = cert_list_length - 1; i >= 0; i--) { - gnutls_x509_crt_deinit (gnutls_verify_cert); - return gnutls_make_error (ret); + gnutls_x509_crt_t cert; + + gnutls_x509_crt_init (&cert); + + if (ret < GNUTLS_E_SUCCESS) + failed_import = ret; + else + { + ret = gnutls_x509_crt_import (cert, &cert_list[i], + GNUTLS_X509_FMT_DER); + + if (ret < GNUTLS_E_SUCCESS) + failed_import = ret; + } + + p->gnutls_certificates[i] = cert; } - XPROCESS (proc)->gnutls_certificate = gnutls_verify_cert; + if (failed_import != 0) + { + gnutls_deinit_certificates (p); + return gnutls_make_error (failed_import); + } - int err = gnutls_x509_crt_check_hostname (gnutls_verify_cert, + int err = gnutls_x509_crt_check_hostname (p->gnutls_certificates[0], c_hostname); check_memory_full (err); if (!err) { - XPROCESS (proc)->gnutls_extra_peer_verification - |= CERTIFICATE_NOT_MATCHING; + p->gnutls_extra_peer_verification |= CERTIFICATE_NOT_MATCHING; if (verify_error_all || !NILP (Fmember (QChostname, verify_error))) { - gnutls_x509_crt_deinit (gnutls_verify_cert); emacs_gnutls_deinit (proc); boot_error (p, "The x509 certificate does not match \"%s\"", c_hostname); @@ -1456,7 +1769,7 @@ gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist) } /* Set this flag only if the whole initialization succeeded. */ - XPROCESS (proc)->gnutls_p = true; + p->gnutls_p = true; return gnutls_make_error (ret); } @@ -1557,13 +1870,13 @@ one trustfile (usually a CA bundle). */) return Qnil; } - hostname = Fplist_get (proplist, QChostname); - priority_string = Fplist_get (proplist, QCpriority); - trustfiles = Fplist_get (proplist, QCtrustfiles); - keylist = Fplist_get (proplist, QCkeylist); - crlfiles = Fplist_get (proplist, QCcrlfiles); - loglevel = Fplist_get (proplist, QCloglevel); - prime_bits = Fplist_get (proplist, QCmin_prime_bits); + hostname = plist_get (proplist, QChostname); + priority_string = plist_get (proplist, QCpriority); + trustfiles = plist_get (proplist, QCtrustfiles); + keylist = plist_get (proplist, QCkeylist); + crlfiles = plist_get (proplist, QCcrlfiles); + loglevel = plist_get (proplist, QCloglevel); + prime_bits = plist_get (proplist, QCmin_prime_bits); if (!STRINGP (hostname)) { @@ -1574,14 +1887,17 @@ one trustfile (usually a CA bundle). */) state = XPROCESS (proc)->gnutls_state; - if (TYPE_RANGED_INTEGERP (int, loglevel)) + if (INTEGERP (loglevel)) { gnutls_global_set_log_function (gnutls_log_function); # ifdef HAVE_GNUTLS3 gnutls_global_set_audit_log_function (gnutls_audit_log_function); # endif - gnutls_global_set_log_level (XINT (loglevel)); - max_log_level = XINT (loglevel); + int level = (FIXNUMP (loglevel) + ? clip_to_bounds (INT_MIN, XFIXNUM (loglevel), INT_MAX) + : NILP (Fnatnump (loglevel)) ? INT_MIN : INT_MAX); + gnutls_global_set_log_level (level); + max_log_level = level; XPROCESS (proc)->gnutls_log_level = max_log_level; } @@ -1613,10 +1929,10 @@ one trustfile (usually a CA bundle). */) check_memory_full (gnutls_certificate_allocate_credentials (&x509_cred)); XPROCESS (proc)->gnutls_x509_cred = x509_cred; - verify_flags = Fplist_get (proplist, QCverify_flags); - if (TYPE_RANGED_INTEGERP (unsigned int, verify_flags)) + verify_flags = plist_get (proplist, QCverify_flags); + if (TYPE_RANGED_FIXNUMP (unsigned int, verify_flags)) { - gnutls_verify_flags = XFASTINT (verify_flags); + gnutls_verify_flags = XFIXNAT (verify_flags); GNUTLS_LOG (2, max_log_level, "setting verification flags"); } else if (NILP (verify_flags)) @@ -1775,8 +2091,8 @@ one trustfile (usually a CA bundle). */) GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_PRIORITY; - if (INTEGERP (prime_bits)) - gnutls_dh_set_prime_bits (state, XUINT (prime_bits)); + if (FIXNUMP (prime_bits)) + gnutls_dh_set_prime_bits (state, XUFIXNUM (prime_bits)); ret = EQ (type, Qgnutls_x509pki) ? gnutls_credentials_set (state, GNUTLS_CRD_CERTIFICATE, x509_cred) @@ -1793,7 +2109,7 @@ one trustfile (usually a CA bundle). */) } XPROCESS (proc)->gnutls_complete_negotiation_p = - !NILP (Fplist_get (proplist, QCcomplete_negotiation)); + !NILP (plist_get (proplist, QCcomplete_negotiation)); GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET; ret = emacs_gnutls_handshake (XPROCESS (proc)); if (ret < GNUTLS_E_SUCCESS) @@ -1825,7 +2141,8 @@ This function may also return `gnutls-e-again', or state = XPROCESS (proc)->gnutls_state; - gnutls_x509_crt_deinit (XPROCESS (proc)->gnutls_certificate); + if (XPROCESS (proc)->gnutls_certificates) + gnutls_deinit_certificates (XPROCESS (proc)); ret = gnutls_bye (state, NILP (cont) ? GNUTLS_SHUT_RDWR : GNUTLS_SHUT_WR); @@ -1836,6 +2153,24 @@ This function may also return `gnutls-e-again', or #ifdef HAVE_GNUTLS3 +# ifndef HAVE_GNUTLS_CIPHER_GET_IV_SIZE + /* Block size is equivalent. */ +# define gnutls_cipher_get_iv_size(cipher) gnutls_cipher_get_block_size (cipher) +# endif + +# ifndef HAVE_GNUTLS_CIPHER_GET_TAG_SIZE + /* Tag size is irrelevant. */ +# define gnutls_cipher_get_tag_size(cipher) 0 +# endif + +# ifndef HAVE_GNUTLS_DIGEST_LIST + /* The mac algorithms are equivalent. */ +# define gnutls_digest_list() \ + ((gnutls_digest_algorithm_t const *) gnutls_mac_list ()) +# define gnutls_digest_get_name(id) \ + gnutls_mac_get_name ((gnutls_mac_algorithm_t) (id)) +# endif + DEFUN ("gnutls-ciphers", Fgnutls_ciphers, Sgnutls_ciphers, 0, 0, 0, doc: /* Return alist of GnuTLS symmetric cipher descriptions as plists. The alist key is the cipher name. */) @@ -1859,20 +2194,20 @@ The alist key is the cipher name. */) ptrdiff_t cipher_tag_size = gnutls_cipher_get_tag_size (gca); Lisp_Object cp - = listn (CONSTYPE_HEAP, 15, cipher_symbol, - QCcipher_id, make_number (gca), + = list (cipher_symbol, + QCcipher_id, make_fixnum (gca), QCtype, Qgnutls_type_cipher, QCcipher_aead_capable, cipher_tag_size == 0 ? Qnil : Qt, - QCcipher_tagsize, make_number (cipher_tag_size), + QCcipher_tagsize, make_fixnum (cipher_tag_size), QCcipher_blocksize, - make_number (gnutls_cipher_get_block_size (gca)), + make_fixnum (gnutls_cipher_get_block_size (gca)), QCcipher_keysize, - make_number (gnutls_cipher_get_key_size (gca)), + make_fixnum (gnutls_cipher_get_key_size (gca)), QCcipher_ivsize, - make_number (gnutls_cipher_get_iv_size (gca))); + make_fixnum (gnutls_cipher_get_iv_size (gca))); ciphers = Fcons (cp, ciphers); } @@ -1959,11 +2294,13 @@ gnutls_symmetric_aead (bool encrypting, gnutls_cipher_algorithm_t gca, SAFE_FREE (); return list2 (output, actual_iv); # else - printmax_t print_gca = gca; - error ("GnuTLS AEAD cipher %"pMd" is invalid or not found", print_gca); + intmax_t print_gca = gca; + error ("GnuTLS AEAD cipher %"PRIdMAX" is invalid or not found", print_gca); # endif } +static Lisp_Object cipher_cache; + static Lisp_Object gnutls_symmetric (bool encrypting, Lisp_Object cipher, Lisp_Object key, Lisp_Object iv, @@ -1994,22 +2331,32 @@ gnutls_symmetric (bool encrypting, Lisp_Object cipher, cipher = intern (SSDATA (cipher)); if (SYMBOLP (cipher)) - info = XCDR (Fassq (cipher, Fgnutls_ciphers ())); - else if (TYPE_RANGED_INTEGERP (gnutls_cipher_algorithm_t, cipher)) - gca = XINT (cipher); + { + if (NILP (cipher_cache)) + cipher_cache = Fgnutls_ciphers (); + info = Fassq (cipher, cipher_cache); + if (!CONSP (info)) + xsignal2 (Qerror, + build_string ("GnuTLS cipher is invalid or not found"), + cipher); + info = XCDR (info); + } + else if (TYPE_RANGED_FIXNUMP (gnutls_cipher_algorithm_t, cipher)) + gca = XFIXNUM (cipher); else info = cipher; if (!NILP (info) && CONSP (info)) { - Lisp_Object v = Fplist_get (info, QCcipher_id); - if (TYPE_RANGED_INTEGERP (gnutls_cipher_algorithm_t, v)) - gca = XINT (v); + Lisp_Object v = plist_get (info, QCcipher_id); + if (TYPE_RANGED_FIXNUMP (gnutls_cipher_algorithm_t, v)) + gca = XFIXNUM (v); } ptrdiff_t key_size = gnutls_cipher_get_key_size (gca); if (key_size == 0) - error ("GnuTLS cipher is invalid or not found"); + xsignal2 (Qerror, + build_string ("GnuTLS cipher is invalid or not found"), cipher); ptrdiff_t kstart_byte, kend_byte; const char *kdata = extract_data_from_object (key, &kstart_byte, &kend_byte); @@ -2117,11 +2464,10 @@ The KEY can be specified as a buffer or string or in other ways (see Info node `(elisp)Format of GnuTLS Cryptography Inputs'). The KEY will be wiped after use if it's a string. -The IV and INPUT and the optional AEAD_AUTH can be specified as a -buffer or string or in other ways (see Info node `(elisp)Format of -GnuTLS Cryptography Inputs'). +The IV and INPUT and the optional AEAD_AUTH can also be specified as a +buffer or string or in other ways. -The alist of symmetric ciphers can be obtained with `gnutls-ciphers`. +The alist of symmetric ciphers can be obtained with `gnutls-ciphers'. The CIPHER may be a string or symbol matching a key in that alist, or a plist with the :cipher-id numeric property, or the number itself. @@ -2144,11 +2490,10 @@ The KEY can be specified as a buffer or string or in other ways (see Info node `(elisp)Format of GnuTLS Cryptography Inputs'). The KEY will be wiped after use if it's a string. -The IV and INPUT and the optional AEAD_AUTH can be specified as a -buffer or string or in other ways (see Info node `(elisp)Format of -GnuTLS Cryptography Inputs'). +The IV and INPUT and the optional AEAD_AUTH can also be specified as a +buffer or string or in other ways. -The alist of symmetric ciphers can be obtained with `gnutls-ciphers`. +The alist of symmetric ciphers can be obtained with `gnutls-ciphers'. The CIPHER may be a string or symbol matching a key in that alist, or a plist with the `:cipher-id' numeric property, or the number itself. @@ -2178,18 +2523,22 @@ name. */) /* A symbol representing the GnuTLS MAC algorithm. */ Lisp_Object gma_symbol = intern (gnutls_mac_get_name (gma)); - Lisp_Object mp = listn (CONSTYPE_HEAP, 11, gma_symbol, - QCmac_algorithm_id, make_number (gma), + size_t nonce_size = 0; +# ifdef HAVE_GNUTLS_MAC_GET_NONCE_SIZE + nonce_size = gnutls_mac_get_nonce_size (gma); +# endif + Lisp_Object mp = list (gma_symbol, + QCmac_algorithm_id, make_fixnum (gma), QCtype, Qgnutls_type_mac_algorithm, QCmac_algorithm_length, - make_number (gnutls_hmac_get_len (gma)), + make_fixnum (gnutls_hmac_get_len (gma)), QCmac_algorithm_keysize, - make_number (gnutls_mac_get_key_size (gma)), + make_fixnum (gnutls_mac_get_key_size (gma)), QCmac_algorithm_noncesize, - make_number (gnutls_mac_get_nonce_size (gma))); + make_fixnum (nonce_size)); mac_algorithms = Fcons (mp, mac_algorithms); } @@ -2213,12 +2562,12 @@ method name. */) /* A symbol representing the GnuTLS digest algorithm. */ Lisp_Object gda_symbol = intern (gnutls_digest_get_name (gda)); - Lisp_Object mp = listn (CONSTYPE_HEAP, 7, gda_symbol, - QCdigest_algorithm_id, make_number (gda), + Lisp_Object mp = list (gda_symbol, + QCdigest_algorithm_id, make_fixnum (gda), QCtype, Qgnutls_type_digest_algorithm, QCdigest_algorithm_length, - make_number (gnutls_hash_get_len (gda))); + make_fixnum (gnutls_hash_get_len (gda))); digest_algorithms = Fcons (mp, digest_algorithms); } @@ -2235,10 +2584,10 @@ The KEY can be specified as a buffer or string or in other ways (see Info node `(elisp)Format of GnuTLS Cryptography Inputs'). The KEY will be wiped after use if it's a string. -The INPUT can be specified as a buffer or string or in other -ways (see Info node `(elisp)Format of GnuTLS Cryptography Inputs'). +The INPUT can also be specified as a buffer or string or in other +ways. -The alist of MAC algorithms can be obtained with `gnutls-macs`. The +The alist of MAC algorithms can be obtained with `gnutls-macs'. The HASH-METHOD may be a string or symbol matching a key in that alist, or a plist with the `:mac-algorithm-id' numeric property, or the number itself. */) @@ -2261,22 +2610,31 @@ itself. */) hash_method = intern (SSDATA (hash_method)); if (SYMBOLP (hash_method)) - info = XCDR (Fassq (hash_method, Fgnutls_macs ())); - else if (TYPE_RANGED_INTEGERP (gnutls_mac_algorithm_t, hash_method)) - gma = XINT (hash_method); + { + info = Fassq (hash_method, Fgnutls_macs ()); + if (!CONSP (info)) + xsignal2 (Qerror, + build_string ("GnuTLS MAC-method is invalid or not found"), + hash_method); + info = XCDR (info); + } + else if (TYPE_RANGED_FIXNUMP (gnutls_mac_algorithm_t, hash_method)) + gma = XFIXNUM (hash_method); else info = hash_method; if (!NILP (info) && CONSP (info)) { - Lisp_Object v = Fplist_get (info, QCmac_algorithm_id); - if (TYPE_RANGED_INTEGERP (gnutls_mac_algorithm_t, v)) - gma = XINT (v); + Lisp_Object v = plist_get (info, QCmac_algorithm_id); + if (TYPE_RANGED_FIXNUMP (gnutls_mac_algorithm_t, v)) + gma = XFIXNUM (v); } ptrdiff_t digest_length = gnutls_hmac_get_len (gma); if (digest_length == 0) - error ("GnuTLS MAC-method is invalid or not found"); + xsignal2 (Qerror, + build_string ("GnuTLS MAC-method is invalid or not found"), + hash_method); ptrdiff_t kstart_byte, kend_byte; const char *kdata = extract_data_from_object (key, &kstart_byte, &kend_byte); @@ -2324,7 +2682,7 @@ Return nil on error. The INPUT can be specified as a buffer or string or in other ways (see Info node `(elisp)Format of GnuTLS Cryptography Inputs'). -The alist of digest algorithms can be obtained with `gnutls-digests`. +The alist of digest algorithms can be obtained with `gnutls-digests'. The DIGEST-METHOD may be a string or symbol matching a key in that alist, or a plist with the `:digest-algorithm-id' numeric property, or the number itself. */) @@ -2342,22 +2700,31 @@ the number itself. */) digest_method = intern (SSDATA (digest_method)); if (SYMBOLP (digest_method)) - info = XCDR (Fassq (digest_method, Fgnutls_digests ())); - else if (TYPE_RANGED_INTEGERP (gnutls_digest_algorithm_t, digest_method)) - gda = XINT (digest_method); + { + info = Fassq (digest_method, Fgnutls_digests ()); + if (!CONSP (info)) + xsignal2 (Qerror, + build_string ("GnuTLS digest-method is invalid or not found"), + digest_method); + info = XCDR (info); + } + else if (TYPE_RANGED_FIXNUMP (gnutls_digest_algorithm_t, digest_method)) + gda = XFIXNUM (digest_method); else info = digest_method; if (!NILP (info) && CONSP (info)) { - Lisp_Object v = Fplist_get (info, QCdigest_algorithm_id); - if (TYPE_RANGED_INTEGERP (gnutls_digest_algorithm_t, v)) - gda = XINT (v); + Lisp_Object v = plist_get (info, QCdigest_algorithm_id); + if (TYPE_RANGED_FIXNUMP (gnutls_digest_algorithm_t, v)) + gda = XFIXNUM (v); } ptrdiff_t digest_length = gnutls_hash_get_len (gda); if (digest_length == 0) - error ("GnuTLS digest-method is invalid or not found"); + xsignal2 (Qerror, + build_string ("GnuTLS digest-method is invalid or not found"), + digest_method); gnutls_hash_hd_t hash; int ret = gnutls_hash_init (&hash, gda); @@ -2399,13 +2766,30 @@ GnuTLS 3 or higher : the list will contain `gnutls3'. GnuTLS MACs : the list will contain `macs'. GnuTLS digests : the list will contain `digests'. GnuTLS symmetric ciphers: the list will contain `ciphers'. -GnuTLS AEAD ciphers : the list will contain `AEAD-ciphers'. */) +GnuTLS AEAD ciphers : the list will contain `AEAD-ciphers'. +%DUMBFW : the list will contain `ClientHello\\ Padding'. +Any GnuTLS extension with ID up to 100 + : the list will contain its name. */) (void) { Lisp_Object capabilities = Qnil; #ifdef HAVE_GNUTLS +# ifdef WINDOWSNT + Lisp_Object found = Fassq (Qgnutls, Vlibrary_cache); + if (CONSP (found)) + return XCDR (found); + + /* Load the GnuTLS DLL and find exported functions. The external + library cache is updated after the capabilities have been + determined. */ + if (!init_gnutls_functions ()) + return Qnil; +# endif /* WINDOWSNT */ + + capabilities = Fcons (intern("gnutls"), capabilities); + # ifdef HAVE_GNUTLS3 capabilities = Fcons (intern("gnutls3"), capabilities); capabilities = Fcons (intern("digests"), capabilities); @@ -2416,19 +2800,25 @@ GnuTLS AEAD ciphers : the list will contain `AEAD-ciphers'. */) # endif capabilities = Fcons (intern("macs"), capabilities); -# endif /* HAVE_GNUTLS3 */ -# ifdef WINDOWSNT - Lisp_Object found = Fassq (Qgnutls, Vlibrary_cache); - if (CONSP (found)) - return XCDR (found); - else +# ifdef HAVE_GNUTLS_EXT_GET_NAME + for (unsigned int ext=0; ext < 100; ext++) { - Lisp_Object status; - status = init_gnutls_functions () ? capabilities : Qnil; - Vlibrary_cache = Fcons (Fcons (Qgnutls, status), Vlibrary_cache); - return status; + const char* name = gnutls_ext_get_name(ext); + if (name != NULL) + { + capabilities = Fcons (intern(name), capabilities); + } } +# endif +# endif /* HAVE_GNUTLS3 */ + +# ifdef HAVE_GNUTLS_EXT__DUMBFW + capabilities = Fcons (intern("ClientHello Padding"), capabilities); +# endif + +# ifdef WINDOWSNT + Vlibrary_cache = Fcons (Fcons (Qgnutls, capabilities), Vlibrary_cache); # endif /* WINDOWSNT */ #endif /* HAVE_GNUTLS */ @@ -2438,18 +2828,24 @@ GnuTLS AEAD ciphers : the list will contain `AEAD-ciphers'. */) void syms_of_gnutls (void) { - DEFSYM (Qlibgnutls_version, "libgnutls-version"); - Fset (Qlibgnutls_version, + DEFVAR_LISP ("libgnutls-version", Vlibgnutls_version, + doc: /* The version of libgnutls that Emacs was compiled with. +The version number is encoded as an integer with the major version in +the ten thousands place, minor version in the hundreds, and patch +level in the ones. For builds without libgnutls, the value is -1. */); + Vlibgnutls_version = make_fixnum #ifdef HAVE_GNUTLS - make_number (GNUTLS_VERSION_MAJOR * 10000 - + GNUTLS_VERSION_MINOR * 100 - + GNUTLS_VERSION_PATCH) + (GNUTLS_VERSION_MAJOR * 10000 + + GNUTLS_VERSION_MINOR * 100 + + GNUTLS_VERSION_PATCH) #else - make_number (-1) + (-1) #endif - ); + ; + #ifdef HAVE_GNUTLS gnutls_global_initialized = 0; + PDUMPER_IGNORE (gnutls_global_initialized); DEFSYM (Qgnutls_code, "gnutls-code"); DEFSYM (Qgnutls_anon, "gnutls-anon"); @@ -2472,7 +2868,6 @@ syms_of_gnutls (void) DEFSYM (QCcipher_blocksize, ":cipher-blocksize"); DEFSYM (QCcipher_keysize, ":cipher-keysize"); DEFSYM (QCcipher_tagsize, ":cipher-tagsize"); - DEFSYM (QCcipher_keysize, ":cipher-keysize"); DEFSYM (QCcipher_ivsize, ":cipher-ivsize"); DEFSYM (QCmac_algorithm_id, ":mac-algorithm-id"); @@ -2490,19 +2885,19 @@ syms_of_gnutls (void) DEFSYM (Qgnutls_e_interrupted, "gnutls-e-interrupted"); Fput (Qgnutls_e_interrupted, Qgnutls_code, - make_number (GNUTLS_E_INTERRUPTED)); + make_fixnum (GNUTLS_E_INTERRUPTED)); DEFSYM (Qgnutls_e_again, "gnutls-e-again"); Fput (Qgnutls_e_again, Qgnutls_code, - make_number (GNUTLS_E_AGAIN)); + make_fixnum (GNUTLS_E_AGAIN)); DEFSYM (Qgnutls_e_invalid_session, "gnutls-e-invalid-session"); Fput (Qgnutls_e_invalid_session, Qgnutls_code, - make_number (GNUTLS_E_INVALID_SESSION)); + make_fixnum (GNUTLS_E_INVALID_SESSION)); DEFSYM (Qgnutls_e_not_ready_for_handshake, "gnutls-e-not-ready-for-handshake"); Fput (Qgnutls_e_not_ready_for_handshake, Qgnutls_code, - make_number (GNUTLS_E_APPLICATION_ERROR_MIN)); + make_fixnum (GNUTLS_E_APPLICATION_ERROR_MIN)); defsubr (&Sgnutls_get_initstage); defsubr (&Sgnutls_asynchronous_parameters); @@ -2514,6 +2909,7 @@ syms_of_gnutls (void) defsubr (&Sgnutls_bye); defsubr (&Sgnutls_peer_status); defsubr (&Sgnutls_peer_status_warning_describe); + defsubr (&Sgnutls_format_certificate); #ifdef HAVE_GNUTLS3 defsubr (&Sgnutls_ciphers); @@ -2523,6 +2919,9 @@ syms_of_gnutls (void) defsubr (&Sgnutls_hash_digest); defsubr (&Sgnutls_symmetric_encrypt); defsubr (&Sgnutls_symmetric_decrypt); + + cipher_cache = Qnil; + staticpro (&cipher_cache); #endif DEFVAR_INT ("gnutls-log-level", global_gnutls_log_level, |