#ifdef HAVE_GNUTLS3
#define fn_gnutls_global_set_audit_log_function gnutls_global_set_audit_log_function
#endif
+#define fn_gnutls_global_set_log_function gnutls_global_set_log_function
#define fn_gnutls_global_set_log_level gnutls_global_set_log_level
- #define fn_gnutls_global_set_mem_functions gnutls_global_set_mem_functions
#define fn_gnutls_handshake gnutls_handshake
#define fn_gnutls_init gnutls_init
+#define fn_gnutls_kx_get gnutls_kx_get
+#define fn_gnutls_kx_get_name gnutls_kx_get_name
+#define fn_gnutls_mac_get gnutls_mac_get
+#define fn_gnutls_mac_get_name gnutls_mac_get_name
+#define fn_gnutls_pk_algorithm_get_name gnutls_pk_algorithm_get_name
+#define fn_gnutls_pk_bits_to_sec_param gnutls_pk_bits_to_sec_param
#define fn_gnutls_priority_set_direct gnutls_priority_set_direct
+#define fn_gnutls_protocol_get_name gnutls_protocol_get_name
+#define fn_gnutls_protocol_get_version gnutls_protocol_get_version
#define fn_gnutls_record_check_pending gnutls_record_check_pending
#define fn_gnutls_record_recv gnutls_record_recv
#define fn_gnutls_record_send gnutls_record_send
#endif /* !WINDOWSNT */
\f
+ /* Report memory exhaustion if ERR is an out-of-memory indication. */
+ static void
+ check_memory_full (int err)
+ {
+ /* When GnuTLS exhausts memory, it doesn't say how much memory it
+ asked for, so tell the Emacs allocator that GnuTLS asked for no
+ bytes. This isn't accurate, but it's good enough. */
+ if (err == GNUTLS_E_MEMORY_ERROR)
+ memory_full (0);
+ }
+
#ifdef HAVE_GNUTLS3
-/* Function to log a simple audit message. */
+/* Log a simple audit message. */
static void
-gnutls_audit_log_function (gnutls_session_t session, const char* string)
+gnutls_audit_log_function (gnutls_session_t session, const char *string)
{
if (global_gnutls_log_level >= 1)
{
return emacs_gnutls_deinit (proc);
}
-/* Initializes global GnuTLS state to defaults.
-Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
-Returns zero on success. */
+static Lisp_Object
+gnutls_hex_string (unsigned char *buf, ptrdiff_t buf_size, const char *prefix)
+{
+ ptrdiff_t prefix_length = strlen (prefix);
+ if ((STRING_BYTES_BOUND - prefix_length) / 3 < buf_size)
+ string_overflow ();
+ Lisp_Object ret = make_uninit_string (prefix_length + 3 * buf_size
+ - (buf_size != 0));
+ char *string = SSDATA (ret);
+ strcpy (string, prefix);
+
+ for (ptrdiff_t i = 0; i < buf_size; i++)
+ sprintf (string + i * 3 + prefix_length,
+ i == buf_size - 1 ? "%02x" : "%02x:",
+ buf[i]);
+
+ return ret;
+}
+
+static Lisp_Object
+gnutls_certificate_details (gnutls_x509_crt_t cert)
+{
+ Lisp_Object res = Qnil;
+ int err;
+ size_t buf_size;
+
+ /* Version. */
+ {
+ int version = fn_gnutls_x509_crt_get_version (cert);
++ check_memory_full (version);
+ if (version >= GNUTLS_E_SUCCESS)
+ res = nconc2 (res, list2 (intern (":version"),
+ make_number (version)));
+ }
+
+ /* Serial. */
+ buf_size = 0;
+ err = fn_gnutls_x509_crt_get_serial (cert, NULL, &buf_size);
++ check_memory_full (err);
+ if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
+ {
+ void *serial = xmalloc (buf_size);
+ err = fn_gnutls_x509_crt_get_serial (cert, serial, &buf_size);
++ check_memory_full (err);
+ if (err >= GNUTLS_E_SUCCESS)
+ res = nconc2 (res, list2 (intern (":serial-number"),
+ gnutls_hex_string (serial, buf_size, "")));
+ xfree (serial);
+ }
+
+ /* Issuer. */
+ buf_size = 0;
+ err = fn_gnutls_x509_crt_get_issuer_dn (cert, NULL, &buf_size);
++ check_memory_full (err);
+ if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
+ {
+ char *dn = xmalloc (buf_size);
+ err = fn_gnutls_x509_crt_get_issuer_dn (cert, dn, &buf_size);
++ check_memory_full (err);
+ if (err >= GNUTLS_E_SUCCESS)
+ res = nconc2 (res, list2 (intern (":issuer"),
+ make_string (dn, buf_size)));
+ xfree (dn);
+ }
+
+ /* Validity. */
+ {
+ /* Add 1 to the buffer size, since 1900 is added to tm_year and
+ that might add 1 to the year length. */
+ char buf[INT_STRLEN_BOUND (int) + 1 + sizeof "-12-31"];
+ struct tm t;
+ time_t tim = fn_gnutls_x509_crt_get_activation_time (cert);
+
+ if (gmtime_r (&tim, &t) && strftime (buf, sizeof buf, "%Y-%m-%d", &t))
+ res = nconc2 (res, list2 (intern (":valid-from"), build_string (buf)));
+
+ tim = fn_gnutls_x509_crt_get_expiration_time (cert);
+ if (gmtime_r (&tim, &t) && strftime (buf, sizeof buf, "%Y-%m-%d", &t))
+ res = nconc2 (res, list2 (intern (":valid-to"), build_string (buf)));
+ }
+
+ /* Subject. */
+ buf_size = 0;
+ err = fn_gnutls_x509_crt_get_dn (cert, NULL, &buf_size);
++ check_memory_full (err);
+ if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
+ {
+ char *dn = xmalloc (buf_size);
+ err = fn_gnutls_x509_crt_get_dn (cert, dn, &buf_size);
++ check_memory_full (err);
+ if (err >= GNUTLS_E_SUCCESS)
+ res = nconc2 (res, list2 (intern (":subject"),
+ make_string (dn, buf_size)));
+ xfree (dn);
+ }
+
+ /* Versions older than 2.11 doesn't have these four functions. */
+#if GNUTLS_VERSION_NUMBER >= 0x020b00
+ /* SubjectPublicKeyInfo. */
+ {
+ unsigned int bits;
+
+ err = fn_gnutls_x509_crt_get_pk_algorithm (cert, &bits);
++ check_memory_full (err);
+ if (err >= GNUTLS_E_SUCCESS)
+ {
+ const char *name = fn_gnutls_pk_algorithm_get_name (err);
+ if (name)
+ res = nconc2 (res, list2 (intern (":public-key-algorithm"),
+ build_string (name)));
+
+ name = fn_gnutls_sec_param_get_name (fn_gnutls_pk_bits_to_sec_param
+ (err, bits));
+ res = nconc2 (res, list2 (intern (":certificate-security-level"),
+ build_string (name)));
+ }
+ }
+
+ /* Unique IDs. */
+ buf_size = 0;
+ err = fn_gnutls_x509_crt_get_issuer_unique_id (cert, NULL, &buf_size);
++ check_memory_full (err);
+ if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
+ {
+ char *buf = xmalloc (buf_size);
+ err = fn_gnutls_x509_crt_get_issuer_unique_id (cert, buf, &buf_size);
++ check_memory_full (err);
+ if (err >= GNUTLS_E_SUCCESS)
+ res = nconc2 (res, list2 (intern (":issuer-unique-id"),
+ make_string (buf, buf_size)));
+ xfree (buf);
+ }
+
+ buf_size = 0;
+ err = fn_gnutls_x509_crt_get_subject_unique_id (cert, NULL, &buf_size);
++ check_memory_full (err);
+ if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
+ {
+ char *buf = xmalloc (buf_size);
+ err = fn_gnutls_x509_crt_get_subject_unique_id (cert, buf, &buf_size);
++ check_memory_full (err);
+ if (err >= GNUTLS_E_SUCCESS)
+ res = nconc2 (res, list2 (intern (":subject-unique-id"),
+ make_string (buf, buf_size)));
+ xfree (buf);
+ }
+#endif
+
+ /* Signature. */
+ err = fn_gnutls_x509_crt_get_signature_algorithm (cert);
++ check_memory_full (err);
+ if (err >= GNUTLS_E_SUCCESS)
+ {
+ const char *name = fn_gnutls_sign_get_name (err);
+ if (name)
+ res = nconc2 (res, list2 (intern (":signature-algorithm"),
+ build_string (name)));
+ }
+
+ /* Public key ID. */
+ buf_size = 0;
+ err = fn_gnutls_x509_crt_get_key_id (cert, 0, NULL, &buf_size);
++ check_memory_full (err);
+ if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
+ {
+ void *buf = xmalloc (buf_size);
+ err = fn_gnutls_x509_crt_get_key_id (cert, 0, buf, &buf_size);
++ check_memory_full (err);
+ if (err >= GNUTLS_E_SUCCESS)
+ res = nconc2 (res, list2 (intern (":public-key-id"),
+ gnutls_hex_string (buf, buf_size, "sha1:")));
+ xfree (buf);
+ }
+
+ /* Certificate fingerprint. */
+ buf_size = 0;
+ err = fn_gnutls_x509_crt_get_fingerprint (cert, GNUTLS_DIG_SHA1,
+ NULL, &buf_size);
++ check_memory_full (err);
+ if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
+ {
+ void *buf = xmalloc (buf_size);
+ err = fn_gnutls_x509_crt_get_fingerprint (cert, GNUTLS_DIG_SHA1,
+ buf, &buf_size);
++ check_memory_full (err);
+ if (err >= GNUTLS_E_SUCCESS)
+ res = nconc2 (res, list2 (intern (":certificate-id"),
+ gnutls_hex_string (buf, buf_size, "sha1:")));
+ xfree (buf);
+ }
+
+ return res;
+}
+
+DEFUN ("gnutls-peer-status-warning-describe", Fgnutls_peer_status_warning_describe, Sgnutls_peer_status_warning_describe, 1, 1, 0,
+ doc: /* Describe the warning of a GnuTLS peer status from `gnutls-peer-status'. */)
+ (Lisp_Object status_symbol)
+{
+ CHECK_SYMBOL (status_symbol);
+
+ if (EQ (status_symbol, intern (":invalid")))
+ return build_string ("certificate could not be verified");
+
+ if (EQ (status_symbol, intern (":revoked")))
+ return build_string ("certificate was revoked (CRL)");
+
+ if (EQ (status_symbol, intern (":self-signed")))
+ return build_string ("certificate signer was not found (self-signed)");
+
+ if (EQ (status_symbol, intern (":not-ca")))
+ return build_string ("certificate signer is not a CA");
+
+ if (EQ (status_symbol, intern (":insecure")))
+ return build_string ("certificate was signed with an insecure algorithm");
+
+ if (EQ (status_symbol, intern (":not-activated")))
+ return build_string ("certificate is not yet activated");
+
+ if (EQ (status_symbol, intern (":expired")))
+ return build_string ("certificate has expired");
+
+ if (EQ (status_symbol, intern (":no-host-match")))
+ return build_string ("certificate host does not match hostname");
+
+ 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'. */)
+ (Lisp_Object proc)
+{
+ Lisp_Object warnings = Qnil, result = Qnil;
+ unsigned int verification;
+ gnutls_session_t state;
+
+ CHECK_PROCESS (proc);
+
+ if (GNUTLS_INITSTAGE (proc) < GNUTLS_STAGE_INIT)
+ return Qnil;
+
+ /* Then collect any warnings already computed by the handshake. */
+ verification = XPROCESS (proc)->gnutls_peer_verification;
+
+ if (verification & GNUTLS_CERT_INVALID)
+ warnings = Fcons (intern (":invalid"), warnings);
+
+ if (verification & GNUTLS_CERT_REVOKED)
+ warnings = Fcons (intern (":revoked"), warnings);
+
+ if (verification & GNUTLS_CERT_SIGNER_NOT_FOUND)
+ warnings = Fcons (intern (":self-signed"), warnings);
+
+ if (verification & GNUTLS_CERT_SIGNER_NOT_CA)
+ warnings = Fcons (intern (":not-ca"), warnings);
+
+ if (verification & GNUTLS_CERT_INSECURE_ALGORITHM)
+ warnings = Fcons (intern (":insecure"), warnings);
+
+ if (verification & GNUTLS_CERT_NOT_ACTIVATED)
+ warnings = Fcons (intern (":not-activated"), warnings);
+
+ if (verification & GNUTLS_CERT_EXPIRED)
+ warnings = Fcons (intern (":expired"), warnings);
+
+ if (XPROCESS (proc)->gnutls_extra_peer_verification &
+ CERTIFICATE_NOT_MATCHING)
+ warnings = Fcons (intern (":no-host-match"), warnings);
+
+ if (!NILP (warnings))
+ result = list2 (intern (":warnings"), warnings);
+
+ /* 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)));
+
+ state = XPROCESS (proc)->gnutls_state;
+
+ /* Diffie-Hellman prime bits. */
+ {
+ int bits = fn_gnutls_dh_get_prime_bits (state);
++ check_memory_full (bits);
+ if (bits > 0)
+ result = nconc2 (result, list2 (intern (":diffie-hellman-prime-bits"),
+ make_number (bits)));
+ }
+
+ /* Key exchange. */
+ result = nconc2
+ (result, list2 (intern (":key-exchange"),
+ build_string (fn_gnutls_kx_get_name
+ (fn_gnutls_kx_get (state)))));
+
+ /* Protocol name. */
+ result = nconc2
+ (result, list2 (intern (":protocol"),
+ build_string (fn_gnutls_protocol_get_name
+ (fn_gnutls_protocol_get_version (state)))));
+
+ /* Cipher name. */
+ result = nconc2
+ (result, list2 (intern (":cipher"),
+ build_string (fn_gnutls_cipher_get_name
+ (fn_gnutls_cipher_get (state)))));
+
+ /* MAC name. */
+ result = nconc2
+ (result, list2 (intern (":mac"),
+ build_string (fn_gnutls_mac_get_name
+ (fn_gnutls_mac_get (state)))));
+
+
+ return result;
+}
+
+/* Initialize global GnuTLS state to defaults.
+ Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
+ Return zero on success. */
static Lisp_Object
emacs_gnutls_global_init (void)
{
int file_format = GNUTLS_X509_FMT_PEM;
Lisp_Object tail;
- GNUTLS_LOG2i (4, max_log_level,
- "setting system trust failed with code ", ret);
+#if GNUTLS_VERSION_MAJOR + \
+ (GNUTLS_VERSION_MINOR > 0 || GNUTLS_VERSION_PATCH >= 20) > 3
+ ret = fn_gnutls_certificate_set_x509_system_trust (x509_cred);
+ if (ret < GNUTLS_E_SUCCESS)
++ {
++ check_memory_full (ret);
++ GNUTLS_LOG2i (4, max_log_level,
++ "setting system trust failed with code ", ret);
++ }
+#endif
+
for (tail = trustfiles; CONSP (tail); tail = XCDR (tail))
{
Lisp_Object trustfile = XCAR (tail);
return gnutls_make_error (ret);
}
- if (!fn_gnutls_x509_crt_check_hostname (gnutls_verify_cert, c_hostname))
+ XPROCESS (proc)->gnutls_certificate = gnutls_verify_cert;
+
+ int err
+ = fn_gnutls_x509_crt_check_hostname (gnutls_verify_cert, c_hostname);
+ check_memory_full (err);
+ if (!err)
{
+ XPROCESS (proc)->gnutls_extra_peer_verification |=
+ CERTIFICATE_NOT_MATCHING;
if (verify_error_all
|| !NILP (Fmember (QCgnutls_bootprop_hostname, verify_error)))
{