procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fix merge conflicts in network-stream-tests.el

Browse source
This commit is contained in:
Lars Ingebrigtsen 2016-02-22 15:06:33 +11:00
commit f577f59a52
14 changed files with 1402 additions and 769 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
configure.ac
View file

@ -2421,6 +2421,13 @@ if test "${HAVE_X11}" = "yes" || test "${HAVE_NS}" = "yes" || test "${HAVE_W32}"
fi
fi
AC_CHECK_LIB(anl, getaddrinfo_a, HAVE_GETADDRINFO_A=yes)
if test "${HAVE_GETADDRINFO_A}" = "yes"; then
AC_DEFINE(HAVE_GETADDRINFO_A, 1,
[Define to 1 if you have getaddrinfo_a for asynchronous DNS resolution.])
GETADDRINFO_A_LIBS="-lanl"
AC_SUBST(GETADDRINFO_A_LIBS)
fi
HAVE_GTK=no
GTK_OBJ=

29
doc/lispref/processes.texi
View file

@ -2415,8 +2415,33 @@ without waiting for the connection to complete. When the connection
succeeds or fails, Emacs will call the sentinel function, with a
second argument matching @code{"open"} (if successful) or
@code{"failed"}. The default is to block, so that
@code{make-network-process} does not return until the connection
has succeeded or failed.
@code{make-network-process} does not return until the connection has
succeeded or failed.
If you're setting up an asynchronous TLS connection, you have to also
provide the @code{:tls-parameters} parameter (see below).
Depending on the capabilities of Emacs, how asynchronous
@code{:nowait} is may vary. The three elements that may (or may not)
be done asynchronously are domain name resolution, socket setup, and
(for TLS connections) TLS negotiation.
Many functions that interact with process objects, (for instance,
@code{process-datagram-address}) rely on them at least having a socket
before they can return a useful value. These functions will block
until the socket has achieved the desired status. The recommended way
of interacting with asynchronous sockets is to place a sentinel on the
process, and not try to interact with it before it has changed status
to @samp{"run"}. That way, none of these functions will block.
@item :tls-parameters
When opening a TLS connection, this should be where the first element
is the TLS type (which should either be @code{gnutls-x509pki} or
@code{gnutls-anon}, and the remaining elements should form a keyword
list acceptable for @code{gnutls-boot}. (This keyword list can be
optained from the @code{gnutls-boot-parameters} function.) The TLS
connection will then be negotiated after completing the connection to
the host.
@item :stop @var{stopped}
If @var{stopped} is non-@code{nil}, start the network connection or

12
doc/misc/emacs-gnutls.texi
View file

@ -173,7 +173,7 @@ Just use @code{open-protocol-stream} or @code{open-network-stream}
You should not have to use the @file{gnutls.el} functions directly.
But you can test them with @code{open-gnutls-stream}.
@defun open-gnutls-stream name buffer host service
@defun open-gnutls-stream name buffer host service &optional nowait
This function creates a buffer connected to a specific @var{host} and
@var{service} (port number or service name). The parameters and their
syntax are the same as those given to @code{open-network-stream}
@ -181,6 +181,10 @@ syntax are the same as those given to @code{open-network-stream}
Manual}). The connection process is called @var{name} (made unique if
necessary). This function returns the connection process.
The @var{nowait} parameter means that the scoket should be
asynchronous, and the connection process will be returned to the
caller before TLS negotiation has happened.
@lisp
;; open a HTTPS connection
(open-gnutls-stream "tls" "tls-buffer" "yourserver.com" "https")
@ -191,6 +195,12 @@ necessary). This function returns the connection process.
@end defun
@findex gnutls-asynchronous-parameters
If called with @var{nowait}, the process is returned immediately
(before connecting to the server). In that case, the process object
is told what parameters to use when negotiating the connection
by using the @code{gnutls-asynchronous-parameters} function.
The function @code{gnutls-negotiate} is not generally useful and it
may change as needed, so please see @file{gnutls.el} for the details.

150
lisp/net/gnutls.el
View file

@ -95,7 +95,7 @@ A value of nil says to use the default GnuTLS value."
(integer :tag "Number of bits" 512))
:group 'gnutls)
(defun open-gnutls-stream (name buffer host service)
(defun open-gnutls-stream (name buffer host service &optional nowait)
"Open a SSL/TLS connection for a service to a host.
Returns a subprocess-object to represent the connection.
Input and output work as for subprocesses; `delete-process' closes it.
@ -109,6 +109,9 @@ BUFFER is the buffer (or `buffer-name') to associate with the process.
Third arg is name of the host to connect to, or its IP address.
Fourth arg SERVICE is name of the service desired, or an integer
specifying a port number to connect to.
Fifth arg NOWAIT (which is optional) means that the socket should
be opened asynchronously. The connection process will be
returned to the caller before TLS negotiation has happened.
Usage example:
@ -122,9 +125,20 @@ This is a very simple wrapper around `gnutls-negotiate'. See its
documentation for the specific parameters you can use to open a
GnuTLS connection, including specifying the credential type,
trust and key files, and priority string."
(gnutls-negotiate :process (open-network-stream name buffer host service)
:type 'gnutls-x509pki
:hostname host))
(let ((process (open-network-stream
name buffer host service
:nowait nowait
:tls-parameters
(and nowait
(cons 'gnutls-x509pki
(gnutls-boot-parameters
:type 'gnutls-x509pki
:hostname host))))))
(if nowait
process
(gnutls-negotiate :process process
:type 'gnutls-x509pki
:hostname host))))
(define-error 'gnutls-error "GnuTLS error")
@ -140,10 +154,45 @@ trust and key files, and priority string."
&allow-other-keys)
"Negotiate a SSL/TLS connection. Returns proc. Signals gnutls-error.
Note arguments are passed CL style, :type TYPE instead of just TYPE.
Note that arguments are passed CL style, :type TYPE instead of just TYPE.
PROCESS is a process returned by `open-network-stream'.
For the meaning of the rest of the parameters, see `gnutls-boot-parameters'."
(let* ((type (or type 'gnutls-x509pki))
;; The gnutls library doesn't understand files delivered via
;; the special handlers, so ignore all files found via those.
(file-name-handler-alist nil)
(params (gnutls-boot-parameters
:type type
:hostname hostname
:priority-string priority-string
:trustfiles trustfiles
:crlfiles crlfiles
:keylist keylist
:min-prime-bits min-prime-bits
:verify-flags verify-flags
:verify-error verify-error
:verify-hostname-error verify-hostname-error))
ret)
(gnutls-message-maybe
(setq ret (gnutls-boot process type params))
"boot: %s" params)
(when (gnutls-errorp ret)
;; This is a error from the underlying C code.
(signal 'gnutls-error (list process ret)))
process))
(cl-defun gnutls-boot-parameters
(&rest spec
&key type hostname priority-string
trustfiles crlfiles keylist min-prime-bits
verify-flags verify-error verify-hostname-error
&allow-other-keys)
"Return a keyword list of parameters suitable for passing to `gnutls-boot'.
TYPE is `gnutls-x509pki' (default) or `gnutls-anon'. Use nil for the default.
PROCESS is a process returned by `open-network-stream'.
HOSTNAME is the remote hostname. It must be a valid string.
PRIORITY-STRING is as per the GnuTLS docs, default is \"NORMAL\".
TRUSTFILES is a list of CA bundles. It defaults to `gnutls-trustfiles'.
@ -189,62 +238,47 @@ here's a recent version of the list.
It must be omitted, a number, or nil; if omitted or nil it
defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT."
(let* ((type (or type 'gnutls-x509pki))
;; The gnutls library doesn't understand files delivered via
;; the special handlers, so ignore all files found via those.
(file-name-handler-alist nil)
(trustfiles (or trustfiles (gnutls-trustfiles)))
(priority-string (or priority-string
(cond
((eq type 'gnutls-anon)
"NORMAL:+ANON-DH:!ARCFOUR-128")
((eq type 'gnutls-x509pki)
(if gnutls-algorithm-priority
(upcase gnutls-algorithm-priority)
"NORMAL")))))
(verify-error (or verify-error
;; this uses the value of `gnutls-verify-error'
(cond
;; if t, pass it on
((eq gnutls-verify-error t)
t)
;; if a list, look for hostname matches
((listp gnutls-verify-error)
(apply 'append
(mapcar
(lambda (check)
(when (string-match (nth 0 check)
hostname)
(nth 1 check)))
gnutls-verify-error)))
;; else it's nil
(t nil))))
(min-prime-bits (or min-prime-bits gnutls-min-prime-bits))
params ret)
(let ((trustfiles (or trustfiles (gnutls-trustfiles)))
(priority-string (or priority-string
(cond
((eq type 'gnutls-anon)
"NORMAL:+ANON-DH:!ARCFOUR-128")
((eq type 'gnutls-x509pki)
(if gnutls-algorithm-priority
(upcase gnutls-algorithm-priority)
"NORMAL")))))
(verify-error (or verify-error
;; this uses the value of `gnutls-verify-error'
(cond
;; if t, pass it on
((eq gnutls-verify-error t)
t)
;; if a list, look for hostname matches
((listp gnutls-verify-error)
(apply 'append
(mapcar
(lambda (check)
(when (string-match (nth 0 check)
hostname)
(nth 1 check)))
gnutls-verify-error)))
;; else it's nil
(t nil))))
(min-prime-bits (or min-prime-bits gnutls-min-prime-bits)))
(when verify-hostname-error
(push :hostname verify-error))
(setq params `(:priority ,priority-string
:hostname ,hostname
:loglevel ,gnutls-log-level
:min-prime-bits ,min-prime-bits
:trustfiles ,trustfiles
:crlfiles ,crlfiles
:keylist ,keylist
:verify-flags ,verify-flags
:verify-error ,verify-error
:callbacks nil))
(gnutls-message-maybe
(setq ret (gnutls-boot process type params))
"boot: %s" params)
(when (gnutls-errorp ret)
;; This is a error from the underlying C code.
(signal 'gnutls-error (list process ret)))
process))
`(:priority ,priority-string
:hostname ,hostname
:loglevel ,gnutls-log-level
:min-prime-bits ,min-prime-bits
:trustfiles ,trustfiles
:crlfiles ,crlfiles
:keylist ,keylist
:verify-flags ,verify-flags
:verify-error ,verify-error
:callbacks nil)))
(defun gnutls-trustfiles ()
"Return a list of usable trustfiles."

66
lisp/net/network-stream.el
View file

@ -136,8 +136,14 @@ non-nil, is used warn the user if the connection isn't encrypted.
:nogreeting is a boolean that can be used to inhibit waiting for
a greeting from the server.
:nowait is a boolean that says the connection should be made
asynchronously, if possible."
:nowait, if non-nil, says the connection should be made
asynchronously, if possible.
:tls-parameters is a list that should be supplied if you're
opening a TLS connection. The first element is the TLS
type (either `gnutls-x509pki' or `gnutls-anon'), and the
remaining elements should be a keyword list accepted by
gnutls-boot (as returned by `gnutls-boot-parameters')."
(unless (featurep 'make-network-process)
(error "Emacs was compiled without networking support"))
(let ((type (plist-get parameters :type))
@ -150,7 +156,9 @@ asynchronously, if possible."
;; The simplest case: wrapper around `make-network-process'.
(make-network-process :name name :buffer buffer
:host (puny-encode-domain host) :service service
:nowait (plist-get parameters :nowait))
:nowait (plist-get parameters :nowait)
:tls-parameters
(plist-get parameters :tls-parameters))
(let ((work-buffer (or buffer
(generate-new-buffer " *stream buffer*")))
(fun (cond ((and (eq type 'plain)
@ -361,32 +369,34 @@ asynchronously, if possible."
(with-current-buffer buffer
(let* ((start (point-max))
(stream
(funcall (if (gnutls-available-p)
'open-gnutls-stream
'open-tls-stream)
name buffer host service))
(if (gnutls-available-p)
(open-gnutls-stream name buffer host service
(plist-get parameters :nowait))
(open-tls-stream name buffer host service)))
(eoc (plist-get parameters :end-of-command)))
;; Check certificate validity etc.
(when (and (gnutls-available-p) stream)
(setq stream (nsm-verify-connection stream host service)))
(if (null stream)
(list nil nil nil 'plain)
;; If we're using tls.el, we have to delete the output from
;; openssl/gnutls-cli.
(when (and (not (gnutls-available-p))
eoc)
(network-stream-get-response stream start eoc)
(goto-char (point-min))
(when (re-search-forward eoc nil t)
(goto-char (match-beginning 0))
(delete-region (point-min) (line-beginning-position))))
(let ((capability-command (plist-get parameters :capability-command))
(eo-capa (or (plist-get parameters :end-of-capability)
eoc)))
(list stream
(network-stream-get-response stream start eoc)
(network-stream-command stream capability-command eo-capa)
'tls))))))
(if (plist-get parameters :nowait)
(list stream nil nil 'tls)
;; Check certificate validity etc.
(when (and (gnutls-available-p) stream)
(setq stream (nsm-verify-connection stream host service)))
(if (null stream)
(list nil nil nil 'plain)
;; If we're using tls.el, we have to delete the output from
;; openssl/gnutls-cli.
(when (and (not (gnutls-available-p))
eoc)
(network-stream-get-response stream start eoc)
(goto-char (point-min))
(when (re-search-forward eoc nil t)
(goto-char (match-beginning 0))
(delete-region (point-min) (line-beginning-position))))
(let ((capability-command (plist-get parameters :capability-command))
(eo-capa (or (plist-get parameters :end-of-capability)
eoc)))
(list stream
(network-stream-get-response stream start eoc)
(network-stream-command stream capability-command eo-capa)
'tls)))))))
(defun network-stream-open-shell (name buffer host service parameters)
(require 'format-spec)

4
lisp/url/url-gw.el
View file

@ -246,8 +246,8 @@ overriding the value of `url-gateway-method'."
:type gw-method
;; Use non-blocking socket if we can.
:nowait (featurep 'make-network-process
'(:nowait t))))
(`socks
'(:nowait t))))
(`socks
(socks-open-network-stream name buffer host service))
(`telnet
(url-open-telnet name buffer host service))

4
src/Makefile.in
View file

@ -235,6 +235,8 @@ IMAGEMAGICK_CFLAGS= @IMAGEMAGICK_CFLAGS@
LIBXML2_LIBS = @LIBXML2_LIBS@
LIBXML2_CFLAGS = @LIBXML2_CFLAGS@
GETADDRINFO_A_LIBS = @GETADDRINFO_A_LIBS@
LIBZ = @LIBZ@
## system-specific libs for dynamic modules, else empty
@ -486,7 +488,7 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \
$(LIBXML2_LIBS) $(LIBGPM) $(LIBRESOLV) $(LIBS_SYSTEM) $(CAIRO_LIBS) \
$(LIBS_TERMCAP) $(GETLOADAVG_LIBS) $(SETTINGS_LIBS) $(LIBSELINUX_LIBS) \
$(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \
$(LIBGNUTLS_LIBS) $(LIB_PTHREAD) \
$(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) \
$(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES)
$(leimdir)/leim-list.el: bootstrap-emacs$(EXEEXT)

15
src/eval.c
View file

@ -1751,9 +1751,9 @@ find_handler_clause (Lisp_Object handlers, Lisp_Object conditions)
}
/* Dump an error message; called like vprintf. */
void
verror (const char *m, va_list ap)
/* Format and return a string; called like vprintf. */
Lisp_Object
vformat_string (const char *m, va_list ap)
{
char buf[4000];
ptrdiff_t size = sizeof buf;
@ -1767,7 +1767,14 @@ verror (const char *m, va_list ap)
if (buffer != buf)
xfree (buffer);
xsignal1 (Qerror, string);
return string;
}
/* Dump an error message; called like vprintf. */
void
verror (const char *m, va_list ap)
{
xsignal1 (Qerror, vformat_string (m, ap));
}

390
src/gnutls.c
View file

@ -397,11 +397,42 @@ gnutls_log_function2i (int level, const char *string, int extra)
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;
do
{
ret = gnutls_handshake (state);
emacs_gnutls_handle_error (state, ret);
QUIT;
}
while (ret < 0 && gnutls_error_is_fatal (ret) == 0 &&
! proc->is_non_blocking_client);
proc->gnutls_initstage = GNUTLS_STAGE_HANDSHAKE_TRIED;
if (proc->is_non_blocking_client)
proc->gnutls_p = 1;
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;
@ -443,26 +474,7 @@ emacs_gnutls_handshake (struct Lisp_Process *proc)
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
@ -528,26 +540,9 @@ emacs_gnutls_read (struct Lisp_Process *proc, char *buf, ptrdiff_t nbyte)
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;
}
return -1;
GNUTLS_LOG (2, log_level, "Giving up on handshake; resetting retries");
proc->gnutls_handshakes_tried = 0;
return 0;
}
rtnval = gnutls_record_recv (state, buf, nbyte);
if (rtnval >= 0)
return rtnval;
@ -686,6 +681,19 @@ emacs_gnutls_deinit (Lisp_Object proc)
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'. */)
@ -1022,7 +1030,7 @@ The return value is a property list with top-level keys :warnings and
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. */
@ -1154,6 +1162,162 @@ emacs_gnutls_global_deinit (void)
}
#endif
/* VARARGS 1 */
static void
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 = 0;
char *c_hostname;
if (NILP (proplist))
proplist = Fcdr (Fplist_get (p->childp, QCtls_parameters));
verify_error = Fplist_get (proplist, QCgnutls_bootprop_verify_error);
hostname = Fplist_get (proplist, QCgnutls_bootprop_hostname);
if (EQ (verify_error, Qt))
{
verify_error_all = 1;
}
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))
{
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);
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;
}
/* 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);
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 = 1;
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
@ -1212,14 +1376,12 @@ one trustfile (usually a CA bundle). */)
{
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. */
@ -1230,19 +1392,24 @@ one trustfile (usually a CA bundle). */)
/* 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");
{
boot_error (p, "GnuTLS not available");
return Qnil;
}
if (!EQ (type, Qgnutls_x509pki) && !EQ (type, Qgnutls_anon))
error ("Invalid GnuTLS credential type");
{
boot_error (p, "Invalid GnuTLS credential type");
return Qnil;
}
hostname = Fplist_get (proplist, QCgnutls_bootprop_hostname);
priority_string = Fplist_get (proplist, QCgnutls_bootprop_priority);
@ -1250,20 +1417,13 @@ one trustfile (usually a CA bundle). */)
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;
}
else if (NILP (Flistp (verify_error)))
{
error ("gnutls-boot: invalid :verify_error parameter (not a list)");
}
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;
@ -1371,7 +1531,8 @@ one trustfile (usually a CA bundle). */)
else
{
emacs_gnutls_deinit (proc);
error ("Invalid trustfile");
boot_error (p, "Invalid trustfile");
return Qnil;
}
}
@ -1395,7 +1556,8 @@ one trustfile (usually a CA bundle). */)
else
{
emacs_gnutls_deinit (proc);
error ("Invalid CRL file");
boot_error (p, "Invalid CRL file");
return Qnil;
}
}
@ -1424,8 +1586,9 @@ one trustfile (usually a CA bundle). */)
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;
}
}
}
@ -1484,109 +1647,7 @@ one trustfile (usually a CA bundle). */)
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,
@ -1693,6 +1754,7 @@ syms_of_gnutls (void)
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);

2
src/gnutls.h
View file

@ -84,6 +84,8 @@ extern void emacs_gnutls_transport_set_errno (gnutls_session_t state, int err);
#endif
extern Lisp_Object emacs_gnutls_deinit (Lisp_Object);
extern Lisp_Object emacs_gnutls_global_init (void);
extern int gnutls_try_handshake (struct Lisp_Process *p);
extern Lisp_Object gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist);
#endif

2
src/lisp.h
View file

@ -3906,6 +3906,8 @@ extern Lisp_Object unbind_to (ptrdiff_t, Lisp_Object);
extern _Noreturn void error (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2);
extern _Noreturn void verror (const char *, va_list)
ATTRIBUTE_FORMAT_PRINTF (1, 0);
extern Lisp_Object vformat_string (const char *, va_list)
ATTRIBUTE_FORMAT_PRINTF (1, 0);
extern void un_autoload (Lisp_Object);
extern Lisp_Object call_debugger (Lisp_Object arg);
extern void *near_C_stack_top (void);

1401
src/process.c
View file

File diff suppressed because it is too large Load diff

25
src/process.h
View file

@ -106,6 +106,7 @@ struct Lisp_Process
#ifdef HAVE_GNUTLS
Lisp_Object gnutls_cred_type;
Lisp_Object gnutls_boot_parameters;
#endif
/* Pipe process attached to the standard error of this process. */
@ -161,7 +162,25 @@ struct Lisp_Process
flag indicates that `raw_status' contains a new status that still
needs to be synced to `status'. */
bool_bf raw_status_new : 1;
/* Whether this is a nonblocking socket. */
bool_bf is_non_blocking_client : 1;
/* Whether this is a server or a client socket. */
bool_bf is_server : 1;
int raw_status;
/* The length of the socket backlog. */
int backlog;
/* The port number. */
int port;
/* The socket type. */
int socktype;
/* The socket protocol. */
int ai_protocol;
#ifdef HAVE_GETADDRINFO_A
/* Whether the socket is waiting for response from an asynchronous
DNS call. */
struct gaicb **dns_requests;
#endif
#ifdef HAVE_GNUTLS
gnutls_initstage_t gnutls_initstage;
@ -191,6 +210,12 @@ pset_childp (struct Lisp_Process *p, Lisp_Object val)
p->childp = val;
}
INLINE void
pset_status (struct Lisp_Process *p, Lisp_Object val)
{
p->status = val;
}
#ifdef HAVE_GNUTLS
INLINE void
pset_gnutls_cred_type (struct Lisp_Process *p, Lisp_Object val)

64
test/lisp/net/network-stream-tests.el
View file

@ -40,7 +40,7 @@
(should (equal (process-contact server :local) file))
(delete-file (process-contact server :local))))
(ert-deftest make-local-tcp-server-with-unspecified-port ()
(ert-deftest make-ipv4-tcp-server-with-unspecified-port ()
(let ((server
(make-network-process
:name "server"
@ -54,7 +54,7 @@
(> (aref (process-contact server :local) 4) 0)))
(delete-process server)))
(ert-deftest make-local-tcp-server-with-specified-port ()
(ert-deftest make-ipv4-tcp-server-with-specified-port ()
(let ((server
(make-network-process
:name "server"
@ -147,9 +147,6 @@
:nowait t
:service port)))
(should (eq (process-status proc) 'connect))
(should (null (ignore-errors
(process-send-string proc "echo bar")
t)))
(while (eq (process-status proc) 'connect)
(sit-for 0.1))
(with-current-buffer (process-buffer proc)
@ -158,17 +155,17 @@
(should (equal (buffer-string) "foo\n")))
(delete-process server)))
(defun make-tls-server ()
(defun make-tls-server (port)
(start-process "gnutls" (generate-new-buffer "*tls*")
"gnutls-serv" "--http"
"--x509keyfile" "lisp/net/key.pem"
"--x509certfile" "lisp/net/cert.pem"
"--port" "44330"))
"--port" (format "%s" port)))
(ert-deftest connect-to-tls-ipv4-wait ()
(skip-unless (executable-find "gnutls-serv"))
(skip-unless (gnutls-available-p))
(let ((server (make-tls-server))
(let ((server (make-tls-server 44332))
(times 0)
proc status)
(sleep-for 1)
@ -181,7 +178,7 @@
:name "bar"
:buffer (generate-new-buffer "*foo*")
:host "localhost"
:service 44330))))
:service 44332))))
(< (setq times (1+ times)) 10))
(sit-for 0.1))
(should proc)
@ -201,11 +198,47 @@
(setq issuer (split-string issuer ","))
(should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
(ert-deftest connect-to-tls-ipv4-nowait ()
(skip-unless (executable-find "gnutls-serv"))
(skip-unless (gnutls-available-p))
(let ((server (make-tls-server 44331))
(times 0)
proc status)
(sleep-for 1)
(with-current-buffer (process-buffer server)
(message "gnutls-serv: %s" (buffer-string)))
;; It takes a while for gnutls-serv to start.
(while (and (null (ignore-errors
(setq proc (make-network-process
:name "bar"
:buffer (generate-new-buffer "*foo*")
:nowait t
:tls-parameters
(cons 'gnutls-x509pki
(gnutls-boot-parameters
:hostname "localhost"))
:host "localhost"
:service 44331))))
(< (setq times (1+ times)) 10))
(sit-for 0.1))
(should proc)
(while (eq (process-status proc) 'connect)
(sit-for 0.1))
(delete-process server)
(setq status (gnutls-peer-status proc))
(should (consp status))
(delete-process proc)
(let ((issuer (plist-get (plist-get status :certificate) :issuer)))
(should (stringp issuer))
(setq issuer (split-string issuer ","))
(should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
(ert-deftest connect-to-tls-ipv6-nowait ()
(skip-unless (executable-find "gnutls-serv"))
(skip-unless (gnutls-available-p))
(skip-unless (not (eq system-type 'windows-nt)))
(let ((server (make-tls-server))
(let ((server (make-tls-server 44333))
(times 0)
proc status)
(sleep-for 1)
@ -219,14 +252,17 @@
:buffer (generate-new-buffer "*foo*")
:family 'ipv6
:nowait t
:tls-parameters
(cons 'gnutls-x509pki
(gnutls-boot-parameters
:hostname "localhost"))
:host "::1"
:service 44330))))
:service 44333))))
(< (setq times (1+ times)) 10))
(sit-for 0.1))
(should proc)
(gnutls-negotiate :process proc
:type 'gnutls-x509pki
:hostname "localhost")
(while (eq (process-status proc) 'connect)
(sit-for 0.1))
(delete-process server)
(setq status (gnutls-peer-status proc))
(should (consp status))