GNU Emacs is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
-the Free Software Foundation, either version 3 of the License, or
-(at your option) any later version.
+the Free Software Foundation, either version 3 of the License, or (at
+your option) any later version.
GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
HMODULE library;
int max_log_level = 1;
- if (!(library = w32_delayed_load (Qgnutls_dll)))
+ if (!(library = w32_delayed_load (Qgnutls)))
{
GNUTLS_LOG (1, max_log_level, "GnuTLS library not found");
return 0;
max_log_level = global_gnutls_log_level;
{
- Lisp_Object name = CAR_SAFE (Fget (Qgnutls_dll, QCloaded_from));
+ Lisp_Object name = CAR_SAFE (Fget (Qgnutls, QCloaded_from));
GNUTLS_LOG2 (1, max_log_level, "GnuTLS library loaded:",
STRINGP (name) ? (const char *) SDATA (name) : "unknown");
}
message ("gnutls.c: [%d] %s %d", level, string, extra);
}
+int
+gnutls_try_handshake (struct Lisp_Process *proc)
+{
+ gnutls_session_t state = proc->gnutls_state;
+ int ret;
+ bool non_blocking = proc->is_non_blocking_client;
+
+ if (proc->gnutls_complete_negotiation_p)
+ non_blocking = false;
+
+ if (non_blocking)
+ proc->gnutls_p = true;
+
+ do
+ {
+ ret = gnutls_handshake (state);
+ emacs_gnutls_handle_error (state, ret);
+ QUIT;
+ }
+ while (ret < 0
+ && gnutls_error_is_fatal (ret) == 0
+ && ! non_blocking);
+
+ proc->gnutls_initstage = GNUTLS_STAGE_HANDSHAKE_TRIED;
+
+ if (ret == GNUTLS_E_SUCCESS)
+ {
+ /* Here we're finally done. */
+ proc->gnutls_initstage = GNUTLS_STAGE_READY;
+ }
+ else
+ {
+ /* check_memory_full (gnutls_alert_send_appropriate (state, ret)); */
+ }
+ return ret;
+}
+
static int
emacs_gnutls_handshake (struct Lisp_Process *proc)
{
gnutls_session_t state = proc->gnutls_state;
- int ret;
if (proc->gnutls_initstage < GNUTLS_STAGE_HANDSHAKE_CANDO)
return -1;
proc->gnutls_initstage = GNUTLS_STAGE_TRANSPORT_POINTERS_SET;
}
- do
- {
- ret = gnutls_handshake (state);
- emacs_gnutls_handle_error (state, ret);
- QUIT;
- }
- while (ret < 0 && gnutls_error_is_fatal (ret) == 0);
-
- proc->gnutls_initstage = GNUTLS_STAGE_HANDSHAKE_TRIED;
-
- if (ret == GNUTLS_E_SUCCESS)
- {
- /* Here we're finally done. */
- proc->gnutls_initstage = GNUTLS_STAGE_READY;
- }
- else
- {
- check_memory_full (gnutls_alert_send_appropriate (state, ret));
- }
- return ret;
+ return gnutls_try_handshake (proc);
}
ptrdiff_t
ssize_t rtnval;
gnutls_session_t state = proc->gnutls_state;
- int log_level = proc->gnutls_log_level;
-
if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
{
- /* If the handshake count is under the limit, try the handshake
- again and increment the handshake count. This count is kept
- per process (connection), not globally. */
- if (proc->gnutls_handshakes_tried < GNUTLS_EMACS_HANDSHAKES_LIMIT)
- {
- proc->gnutls_handshakes_tried++;
- emacs_gnutls_handshake (proc);
- GNUTLS_LOG2i (5, log_level, "Retried handshake",
- proc->gnutls_handshakes_tried);
- return -1;
- }
-
- GNUTLS_LOG (2, log_level, "Giving up on handshake; resetting retries");
- proc->gnutls_handshakes_tried = 0;
- return 0;
+ errno = EAGAIN;
+ return -1;
}
+
rtnval = gnutls_record_recv (state, buf, nbyte);
if (rtnval >= 0)
return rtnval;
CHECK_PROCESS (proc);
- if (XPROCESS (proc)->gnutls_p == 0)
+ if (! XPROCESS (proc)->gnutls_p)
return Qnil;
log_level = XPROCESS (proc)->gnutls_log_level;
GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT - 1;
}
- XPROCESS (proc)->gnutls_p = 0;
+ XPROCESS (proc)->gnutls_p = false;
return Qt;
}
+DEFUN ("gnutls-asynchronous-parameters", Fgnutls_asynchronous_parameters,
+ Sgnutls_asynchronous_parameters, 2, 2, 0,
+ doc: /* Mark this process as being a pre-init GnuTLS process.
+The second parameter is the list of parameters to feed to gnutls-boot
+to finish setting up the connection. */)
+ (Lisp_Object proc, Lisp_Object params)
+{
+ CHECK_PROCESS (proc);
+
+ XPROCESS (proc)->gnutls_boot_parameters = params;
+ return Qnil;
+}
+
DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage, Sgnutls_get_initstage, 1, 1, 0,
doc: /* Return the GnuTLS init stage of process PROC.
See also `gnutls-boot'. */)
attributes: const)
(Lisp_Object err)
{
- if (EQ (err, Qt)) return Qnil;
+ if (EQ (err, Qt)
+ || EQ (err, Qgnutls_e_again))
+ return Qnil;
return Qt;
}
CHECK_PROCESS (proc);
- if (GNUTLS_INITSTAGE (proc) < GNUTLS_STAGE_INIT)
+ if (GNUTLS_INITSTAGE (proc) != GNUTLS_STAGE_READY)
return Qnil;
/* Then collect any warnings already computed by the handshake. */
}
#endif
+static void ATTRIBUTE_FORMAT_PRINTF (2, 3)
+boot_error (struct Lisp_Process *p, const char *m, ...)
+{
+ va_list ap;
+ va_start (ap, m);
+ if (p->is_non_blocking_client)
+ pset_status (p, list2 (Qfailed, vformat_string (m, ap)));
+ else
+ verror (m, ap);
+}
+
+Lisp_Object
+gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist)
+{
+ int ret;
+ struct Lisp_Process *p = XPROCESS (proc);
+ gnutls_session_t state = p->gnutls_state;
+ unsigned int peer_verification;
+ Lisp_Object warnings;
+ int max_log_level = p->gnutls_log_level;
+ Lisp_Object hostname, verify_error;
+ bool verify_error_all = false;
+ char *c_hostname;
+
+ if (NILP (proplist))
+ proplist = Fcdr (Fplist_get (p->childp, QCtls_parameters));
+
+ verify_error = Fplist_get (proplist, QCverify_error);
+ hostname = Fplist_get (proplist, QChostname);
+
+ if (EQ (verify_error, Qt))
+ verify_error_all = true;
+ else if (NILP (Flistp (verify_error)))
+ {
+ boot_error (p,
+ "gnutls-boot: invalid :verify_error parameter (not a list)");
+ return Qnil;
+ }
+
+ if (!STRINGP (hostname))
+ {
+ boot_error (p, "gnutls-boot: invalid :hostname parameter (not a string)");
+ return Qnil;
+ }
+ c_hostname = SSDATA (hostname);
+
+ /* Now verify the peer, following
+ http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
+ The peer should present at least one certificate in the chain; do a
+ check of the certificate's hostname with
+ gnutls_x509_crt_check_hostname against :hostname. */
+
+ ret = gnutls_certificate_verify_peers2 (state, &peer_verification);
+ if (ret < GNUTLS_E_SUCCESS)
+ return gnutls_make_error (ret);
+
+ XPROCESS (proc)->gnutls_peer_verification = peer_verification;
+
+ warnings = Fplist_get (Fgnutls_peer_status (proc), intern (":warnings"));
+ if (!NILP (warnings))
+ {
+ for (Lisp_Object tail = warnings; CONSP (tail); tail = XCDR (tail))
+ {
+ Lisp_Object warning = XCAR (tail);
+ Lisp_Object message = Fgnutls_peer_status_warning_describe (warning);
+ if (!NILP (message))
+ GNUTLS_LOG2 (1, max_log_level, "verification:", SSDATA (message));
+ }
+ }
+
+ if (peer_verification != 0)
+ {
+ if (verify_error_all
+ || !NILP (Fmember (QCtrustfiles, verify_error)))
+ {
+ emacs_gnutls_deinit (proc);
+ boot_error (p,
+ "Certificate validation failed %s, verification code %x",
+ c_hostname, peer_verification);
+ return Qnil;
+ }
+ else
+ {
+ GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:",
+ c_hostname);
+ }
+ }
+
+ /* Up to here the process is the same for X.509 certificates and
+ OpenPGP keys. From now on X.509 certificates are assumed. This
+ 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;
+
+ 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);
+
+ if (gnutls_verify_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);
+
+ if (ret < GNUTLS_E_SUCCESS)
+ {
+ gnutls_x509_crt_deinit (gnutls_verify_cert);
+ return gnutls_make_error (ret);
+ }
+
+ XPROCESS (proc)->gnutls_certificate = gnutls_verify_cert;
+
+ int err = 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 (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);
+ return Qnil;
+ }
+ else
+ GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not match:",
+ c_hostname);
+ }
+ }
+
+ /* Set this flag only if the whole initialization succeeded. */
+ XPROCESS (proc)->gnutls_p = true;
+
+ return gnutls_make_error (ret);
+}
+
DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
doc: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
Currently only client mode is supported. Return a success/failure
:min-prime-bits is the minimum accepted number of bits the client will
accept in Diffie-Hellman key exchange.
+:complete-negotiation, if non-nil, will make negotiation complete
+before returning even on non-blocking sockets.
+
The debug level will be set for this process AND globally for GnuTLS.
So if you set it higher or lower at any point, it affects global
debugging.
{
int ret = GNUTLS_E_SUCCESS;
int max_log_level = 0;
- bool verify_error_all = 0;
gnutls_session_t state;
gnutls_certificate_credentials_t x509_cred = NULL;
gnutls_anon_client_credentials_t anon_cred = NULL;
Lisp_Object global_init;
char const *priority_string_ptr = "NORMAL"; /* default priority string. */
- unsigned int peer_verification;
char *c_hostname;
/* Placeholders for the property list elements. */
/* Lisp_Object callbacks; */
Lisp_Object loglevel;
Lisp_Object hostname;
- Lisp_Object verify_error;
Lisp_Object prime_bits;
- Lisp_Object warnings;
+ struct Lisp_Process *p = XPROCESS (proc);
CHECK_PROCESS (proc);
CHECK_SYMBOL (type);
CHECK_LIST (proplist);
if (NILP (Fgnutls_available_p ()))
- error ("GnuTLS not available");
-
- if (!EQ (type, Qgnutls_x509pki) && !EQ (type, Qgnutls_anon))
- error ("Invalid GnuTLS credential type");
-
- hostname = Fplist_get (proplist, QCgnutls_bootprop_hostname);
- priority_string = Fplist_get (proplist, QCgnutls_bootprop_priority);
- trustfiles = Fplist_get (proplist, QCgnutls_bootprop_trustfiles);
- keylist = Fplist_get (proplist, QCgnutls_bootprop_keylist);
- crlfiles = Fplist_get (proplist, QCgnutls_bootprop_crlfiles);
- loglevel = Fplist_get (proplist, QCgnutls_bootprop_loglevel);
- verify_error = Fplist_get (proplist, QCgnutls_bootprop_verify_error);
- prime_bits = Fplist_get (proplist, QCgnutls_bootprop_min_prime_bits);
-
- if (EQ (verify_error, Qt))
{
- verify_error_all = 1;
+ boot_error (p, "GnuTLS not available");
+ return Qnil;
}
- else if (NILP (Flistp (verify_error)))
+
+ if (!EQ (type, Qgnutls_x509pki) && !EQ (type, Qgnutls_anon))
{
- error ("gnutls-boot: invalid :verify_error parameter (not a list)");
+ boot_error (p, "Invalid GnuTLS credential type");
+ 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);
+
if (!STRINGP (hostname))
- error ("gnutls-boot: invalid :hostname parameter (not a string)");
+ {
+ boot_error (p, "gnutls-boot: invalid :hostname parameter (not a string)");
+ return Qnil;
+ }
c_hostname = SSDATA (hostname);
state = XPROCESS (proc)->gnutls_state;
check_memory_full (gnutls_certificate_allocate_credentials (&x509_cred));
XPROCESS (proc)->gnutls_x509_cred = x509_cred;
- verify_flags = Fplist_get (proplist, QCgnutls_bootprop_verify_flags);
+ verify_flags = Fplist_get (proplist, QCverify_flags);
if (NUMBERP (verify_flags))
{
gnutls_verify_flags = XINT (verify_flags);
else
{
emacs_gnutls_deinit (proc);
- error ("Invalid trustfile");
+ boot_error (p, "Invalid trustfile");
+ return Qnil;
}
}
else
{
emacs_gnutls_deinit (proc);
- error ("Invalid CRL file");
+ boot_error (p, "Invalid CRL file");
+ return Qnil;
}
}
else
{
emacs_gnutls_deinit (proc);
- error (STRINGP (keyfile) ? "Invalid client cert file"
- : "Invalid client key file");
+ boot_error (p, STRINGP (keyfile) ? "Invalid client cert file"
+ : "Invalid client key file");
+ return Qnil;
}
}
}
return gnutls_make_error (ret);
}
+ XPROCESS (proc)->gnutls_complete_negotiation_p =
+ !NILP (Fplist_get (proplist, QCcomplete_negotiation));
GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET;
ret = emacs_gnutls_handshake (XPROCESS (proc));
if (ret < GNUTLS_E_SUCCESS)
return gnutls_make_error (ret);
- /* Now verify the peer, following
- http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
- The peer should present at least one certificate in the chain; do a
- check of the certificate's hostname with
- gnutls_x509_crt_check_hostname against :hostname. */
-
- ret = gnutls_certificate_verify_peers2 (state, &peer_verification);
- if (ret < GNUTLS_E_SUCCESS)
- return gnutls_make_error (ret);
-
- XPROCESS (proc)->gnutls_peer_verification = peer_verification;
-
- warnings = Fplist_get (Fgnutls_peer_status (proc), intern (":warnings"));
- if (!NILP (warnings))
- {
- Lisp_Object tail;
- for (tail = warnings; CONSP (tail); tail = XCDR (tail))
- {
- Lisp_Object warning = XCAR (tail);
- Lisp_Object message = Fgnutls_peer_status_warning_describe (warning);
- if (!NILP (message))
- GNUTLS_LOG2 (1, max_log_level, "verification:", SSDATA (message));
- }
- }
-
- if (peer_verification != 0)
- {
- if (verify_error_all
- || !NILP (Fmember (QCgnutls_bootprop_trustfiles, verify_error)))
- {
- emacs_gnutls_deinit (proc);
- error ("Certificate validation failed %s, verification code %x",
- c_hostname, peer_verification);
- }
- else
- {
- GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:",
- c_hostname);
- }
- }
-
- /* Up to here the process is the same for X.509 certificates and
- OpenPGP keys. From now on X.509 certificates are assumed. This
- 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;
-
- 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);
-
- if (gnutls_verify_cert_list == NULL)
- {
- gnutls_x509_crt_deinit (gnutls_verify_cert);
- emacs_gnutls_deinit (proc);
- error ("No x509 certificate was found\n");
- }
-
- /* We only check the first certificate in the given chain. */
- ret = gnutls_x509_crt_import (gnutls_verify_cert,
- &gnutls_verify_cert_list[0],
- GNUTLS_X509_FMT_DER);
-
- if (ret < GNUTLS_E_SUCCESS)
- {
- gnutls_x509_crt_deinit (gnutls_verify_cert);
- return gnutls_make_error (ret);
- }
-
- XPROCESS (proc)->gnutls_certificate = gnutls_verify_cert;
-
- int err = 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)))
- {
- gnutls_x509_crt_deinit (gnutls_verify_cert);
- emacs_gnutls_deinit (proc);
- error ("The x509 certificate does not match \"%s\"", c_hostname);
- }
- else
- {
- GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not match:",
- c_hostname);
- }
- }
- }
-
- /* Set this flag only if the whole initialization succeeded. */
- XPROCESS (proc)->gnutls_p = 1;
-
- return gnutls_make_error (ret);
+ return gnutls_verify_boot (proc, proplist);
}
DEFUN ("gnutls-bye", Fgnutls_bye,
{
#ifdef HAVE_GNUTLS
# ifdef WINDOWSNT
- Lisp_Object found = Fassq (Qgnutls_dll, Vlibrary_cache);
+ Lisp_Object found = Fassq (Qgnutls, Vlibrary_cache);
if (CONSP (found))
return XCDR (found);
else
{
Lisp_Object status;
status = init_gnutls_functions () ? Qt : Qnil;
- Vlibrary_cache = Fcons (Fcons (Qgnutls_dll, status), Vlibrary_cache);
+ Vlibrary_cache = Fcons (Fcons (Qgnutls, status), Vlibrary_cache);
return status;
}
# else /* !WINDOWSNT */
DEFSYM (Qgnutls_x509pki, "gnutls-x509pki");
/* The following are for the property list of 'gnutls-boot'. */
- DEFSYM (QCgnutls_bootprop_hostname, ":hostname");
- DEFSYM (QCgnutls_bootprop_priority, ":priority");
- DEFSYM (QCgnutls_bootprop_trustfiles, ":trustfiles");
- DEFSYM (QCgnutls_bootprop_keylist, ":keylist");
- DEFSYM (QCgnutls_bootprop_crlfiles, ":crlfiles");
- DEFSYM (QCgnutls_bootprop_min_prime_bits, ":min-prime-bits");
- DEFSYM (QCgnutls_bootprop_loglevel, ":loglevel");
- DEFSYM (QCgnutls_bootprop_verify_flags, ":verify-flags");
- DEFSYM (QCgnutls_bootprop_verify_error, ":verify-error");
+ DEFSYM (QChostname, ":hostname");
+ DEFSYM (QCpriority, ":priority");
+ DEFSYM (QCtrustfiles, ":trustfiles");
+ DEFSYM (QCkeylist, ":keylist");
+ DEFSYM (QCcrlfiles, ":crlfiles");
+ DEFSYM (QCmin_prime_bits, ":min-prime-bits");
+ DEFSYM (QCloglevel, ":loglevel");
+ DEFSYM (QCcomplete_negotiation, ":complete-negotiation");
+ DEFSYM (QCverify_flags, ":verify-flags");
+ DEFSYM (QCverify_error, ":verify-error");
DEFSYM (Qgnutls_e_interrupted, "gnutls-e-interrupted");
Fput (Qgnutls_e_interrupted, Qgnutls_code,
make_number (GNUTLS_E_APPLICATION_ERROR_MIN));
defsubr (&Sgnutls_get_initstage);
+ defsubr (&Sgnutls_asynchronous_parameters);
defsubr (&Sgnutls_errorp);
defsubr (&Sgnutls_error_fatalp);
defsubr (&Sgnutls_error_string);