commit a4e351b0971fda0606cbc4641a6c28e13adef6ca (HEAD, refs/remotes/origin/master) Author: Lars Ingebrigtsen Date: Mon Feb 22 16:18:32 2016 +1100 Mention the further asynchronousity diff --git a/etc/NEWS b/etc/NEWS index 4532a18..bc3e490 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -31,6 +31,22 @@ otherwise leave it unmarked. * Changes in Emacs 25.2 ++++ +** The networking code has been reworked so that it's more +asynchronous than it was (when specifying :nowait t in +`make-network-process'). How asynchronous it is varies based on the +capabilities of the system, but on a typical GNU/Linux system the DNS +resolution, the connection, and (for TLS streams) the TLS negotiation +are all done without blocking the main Emacs thread. To get +asynchronous TLS, the TLS boot parameters have to be passed in (see +the manual for details). + +Certain process oriented functions (like `process-datagram-address') +will block until socket setup has been performed. The recommended way +to deal with asynchronous sockets is to avoid interacting with them +until they have changed status to "run". This is most easily done +from a process sentinel. + ** It is possible to disable attempted recovery on fatal signals Two new variables allow to disable attempts to recover from stack commit 87e9e1b61cd4c0356e7f357f5cee6c226dc6fd35 Author: Lars Ingebrigtsen Date: Mon Feb 22 15:29:15 2016 +1100 Fix async TLS boot problem * src/process.c (wait_reading_process_output): Verify the boot of the correct process. diff --git a/src/process.c b/src/process.c index 7679f69..5172518 100644 --- a/src/process.c +++ b/src/process.c @@ -4927,7 +4927,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, if (p->gnutls_initstage == GNUTLS_STAGE_READY) { - gnutls_verify_boot (proc, Qnil); + gnutls_verify_boot (aproc, Qnil); finish_after_tls_connection (aproc); } else if (p->gnutls_handshakes_tried > commit 6bdd366db88a11de3ca1eab38e5091f84fad9806 Author: Lars Ingebrigtsen Date: Mon Feb 22 15:20:14 2016 +1100 Clean up forgotten text in manual * doc/lispref/display.texi (Defining Images): Remove example forgotten when making previous change. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index c49cca2..457a53c 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -5450,11 +5450,6 @@ set by using @code{setf}. Setting a property to @code{nil} will remove the property from the image. @end defun -@lisp -(image-set-property image :height 300) -@end lisp -@end defun - @defun find-image specs This function provides a convenient way to find an image satisfying one of a list of image specifications @var{specs}. commit f50074922e2f68c66f3db848495bc5f13f32ae22 Author: Lars Ingebrigtsen Date: Mon Feb 22 15:18:41 2016 +1100 Clean up debugging code * src/process.c (Fmake_network_process): Remove debugging printf. (wait_for_socket_fds, wait_while_connecting) (wait_for_tls_negotiation): Remove newlines from messages. diff --git a/src/process.c b/src/process.c index c881a20..7679f69 100644 --- a/src/process.c +++ b/src/process.c @@ -3787,7 +3787,6 @@ usage: (make-network-process &rest ARGS) */) { int ret; - printf("Async DNS for '%s'\n", SSDATA (host)); dns_requests = xmalloc (sizeof (struct gaicb*)); dns_requests[0] = xmalloc (sizeof (struct gaicb)); dns_requests[0]->ar_name = strdup (SSDATA (host)); @@ -4743,7 +4742,7 @@ wait_for_socket_fds (Lisp_Object process, char *name) while (XPROCESS (process)->infd < 0 && EQ (XPROCESS (process)->status, Qconnect)) { - add_to_log ("Waiting for socket from %s...\n", build_string (name)); + add_to_log ("Waiting for socket from %s...", build_string (name)); wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0); } } @@ -4753,7 +4752,7 @@ wait_while_connecting (Lisp_Object process) { while (EQ (XPROCESS (process)->status, Qconnect)) { - add_to_log ("Waiting for connection...\n"); + add_to_log ("Waiting for connection..."); wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0); } } @@ -4765,7 +4764,7 @@ wait_for_tls_negotiation (Lisp_Object process) while (XPROCESS (process)->gnutls_p && XPROCESS (process)->gnutls_initstage != GNUTLS_STAGE_READY) { - add_to_log ("Waiting for TLS...\n"); + add_to_log ("Waiting for TLS..."); wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0); } #endif commit f577f59a5216bc7708bb840f5eac3e82950e81e8 Merge: 5df6e32 0d3c0f6 Author: Lars Ingebrigtsen Date: Mon Feb 22 15:06:33 2016 +1100 Fix merge conflicts in network-stream-tests.el commit 5df6e3212bbb3213d1704dab89299a96b60eac6d Author: Paul Eggert Date: Sun Feb 21 19:59:44 2016 -0800 Port recent filevercmp addition to MS-Windows Reported by Andy Moreton in: http://lists.gnu.org/archive/html/emacs-devel/2016-02/msg01302.html * nt/gnulib.mk (libgnu_a_SOURCES): Add filevercmp.c. (EXTRA_DIST): Add filevercmp.h. diff --git a/nt/gnulib.mk b/nt/gnulib.mk index 6884bf9..fdbad17 100644 --- a/nt/gnulib.mk +++ b/nt/gnulib.mk @@ -1,4 +1,4 @@ -## This file is an edited copy if ../lib/gnulib.mk. +## This file is an edited copy of ../lib/gnulib.mk. ## ## The purpose of the edits is to avoid generating any headers ## which would conflict with either the headers we have in nt/inc, @@ -43,7 +43,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=close --avoid=dup --avoid=fchdir --avoid=flexmember --avoid=fstat --avoid=malloc-posix --avoid=msvc-inval --avoid=msvc-nothrow --avoid=open --avoid=openat-die --avoid=opendir --avoid=raise --avoid=save-cwd --avoid=select --avoid=setenv --avoid=sigprocmask --avoid=stdarg --avoid=stdbool --avoid=threadlib --avoid=unsetenv --makefile-name=gnulib.mk --conditional-dependencies --no-libtool --macro-prefix=gl --no-vc-files alloca-opt binary-io byteswap c-ctype c-strcase careadlinkat close-stream count-one-bits count-trailing-zeros crypto/md5 crypto/sha1 crypto/sha256 crypto/sha512 dtoastr dtotimespec dup2 environ execinfo faccessat fcntl fcntl-h fdatasync fdopendir filemode fstatat fsync getloadavg getopt-gnu gettime gettimeofday gitlog-to-changelog intprops largefile lstat manywarnings memrchr mkostemp mktime pipe2 pselect pthread_sigmask putenv qcopy-acl readlink readlinkat sig2str socklen stat-time stdalign stddef stdio stpcpy strftime strtoimax strtoumax symlink sys_stat sys_time time time_r time_rz timegm timer-time timespec-add timespec-sub unsetenv update-copyright utimens vla warnings +# Reproduce by: gnulib-tool --import --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=close --avoid=dup --avoid=fchdir --avoid=flexmember --avoid=fstat --avoid=malloc-posix --avoid=msvc-inval --avoid=msvc-nothrow --avoid=open --avoid=openat-die --avoid=opendir --avoid=raise --avoid=save-cwd --avoid=select --avoid=setenv --avoid=sigprocmask --avoid=stdarg --avoid=stdbool --avoid=threadlib --avoid=unsetenv --makefile-name=gnulib.mk --conditional-dependencies --no-libtool --macro-prefix=gl --no-vc-files alloca-opt binary-io byteswap c-ctype c-strcase careadlinkat close-stream count-one-bits count-trailing-zeros crypto/md5 crypto/sha1 crypto/sha256 crypto/sha512 dtoastr dtotimespec dup2 environ execinfo faccessat fcntl fcntl-h fdatasync fdopendir filemode filevercmp fstatat fsync getloadavg getopt-gnu gettime gettimeofday gitlog-to-changelog ignore-value intprops largefile lstat manywarnings memrchr mkostemp mktime pipe2 pselect pthread_sigmask putenv qcopy-acl readlink readlinkat sig2str socklen stat-time std-gnu11 stdalign stddef stdio stpcpy strftime strtoimax strtoumax symlink sys_stat sys_time time time_r time_rz timegm timer-time timespec-add timespec-sub unsetenv update-copyright utimens vla warnings MOSTLYCLEANFILES += core *.stackdump @@ -334,6 +334,14 @@ EXTRA_DIST += filemode.h ## end gnulib module filemode +## begin gnulib module filevercmp + +libgnu_a_SOURCES += filevercmp.c + +EXTRA_DIST += filevercmp.h + +## end gnulib module filevercmp + ## begin gnulib module fpending @@ -1082,6 +1090,7 @@ EXTRA_DIST += utimens.h ## begin gnulib module verify + EXTRA_DIST += verify.h ## end gnulib module verify commit 0d3c0f6f906d5494f76b8b686bae72853b1f729c (refs/remotes/origin/feature/async-dns) Author: Lars Ingebrigtsen Date: Mon Feb 22 13:34:54 2016 +1100 add_to_log expects Lisp parameters diff --git a/src/process.c b/src/process.c index 72580a2..c881a20 100644 --- a/src/process.c +++ b/src/process.c @@ -4743,7 +4743,7 @@ wait_for_socket_fds (Lisp_Object process, char *name) while (XPROCESS (process)->infd < 0 && EQ (XPROCESS (process)->status, Qconnect)) { - add_to_log ("Waiting for socket from %s...\n", name); + add_to_log ("Waiting for socket from %s...\n", build_string (name)); wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0); } } commit 41895f93be76cc1489856debaa3578f849451984 Author: Lars Ingebrigtsen Date: Mon Feb 22 13:20:04 2016 +1100 Mention sentinels in conjunction with :nowait t. * doc/lispref/processes.texi (Network Processes): Mention the recommended way of using sentinels with :nowait t. diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index 8234501..79cebaa 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -2426,6 +2426,14 @@ Depending on the capabilities of Emacs, how asynchronous 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 commit b55bf9f45acff424710c5192342a82175e12ddf8 Author: Lars Ingebrigtsen Date: Mon Feb 22 13:14:35 2016 +1100 Mention in the doc strings that process functions may block (Fprocess_contact, Fprocess_datagram_address) (Fset_process_datagram_address, Fset_network_process_option) (Fprocess_send_region, Fprocess_send_string): Mention that the functions may block. (Fset_process_coding_system): Ditto. diff --git a/src/process.c b/src/process.c index 79f8072..72580a2 100644 --- a/src/process.c +++ b/src/process.c @@ -1214,7 +1214,9 @@ SERVICE) for a network connection or (PORT SPEED) for a serial connection. If KEY is t, the complete contact information for the connection is returned, else the specific value for the keyword KEY is returned. See `make-network-process' or `make-serial-process' for a -list of keywords. */) +list of keywords. +If PROCESS is a non-blocking network process that hasn't been fully +set up yet, this function will block until socket setup has completed. */) (register Lisp_Object process, Lisp_Object key) { Lisp_Object contact; @@ -2449,7 +2451,9 @@ conv_lisp_to_sockaddr (int family, Lisp_Object address, struct sockaddr *sa, int #ifdef DATAGRAM_SOCKETS DEFUN ("process-datagram-address", Fprocess_datagram_address, Sprocess_datagram_address, 1, 1, 0, - doc: /* Get the current datagram address associated with PROCESS. */) + doc: /* Get the current datagram address associated with PROCESS. +If PROCESS is a non-blocking network process that hasn't been fully +set up yet, this function will block until socket setup has completed. */) (Lisp_Object process) { int channel; @@ -2470,7 +2474,10 @@ DEFUN ("process-datagram-address", Fprocess_datagram_address, Sprocess_datagram_ DEFUN ("set-process-datagram-address", Fset_process_datagram_address, Sset_process_datagram_address, 2, 2, 0, doc: /* Set the datagram address for PROCESS to ADDRESS. -Returns nil upon error setting address, ADDRESS otherwise. */) +Returns nil upon error setting address, ADDRESS otherwise. + +If PROCESS is a non-blocking network process that hasn't been fully +set up yet, this function will block until socket setup has completed. */) (Lisp_Object process, Lisp_Object address) { int channel; @@ -2638,7 +2645,10 @@ DEFUN ("set-network-process-option", doc: /* For network process PROCESS set option OPTION to value VALUE. See `make-network-process' for a list of options and values. If optional fourth arg NO-ERROR is non-nil, don't signal an error if -OPTION is not a supported option, return nil instead; otherwise return t. */) +OPTION is not a supported option, return nil instead; otherwise return t. + +If PROCESS is a non-blocking network process that hasn't been fully +set up yet, this function will block until socket setup has completed. */) (Lisp_Object process, Lisp_Object option, Lisp_Object value, Lisp_Object no_error) { int s; @@ -6247,7 +6257,10 @@ nil, indicating the current buffer's process. Called from program, takes three arguments, PROCESS, START and END. If the region is more than 500 characters long, it is sent in several bunches. This may happen even for shorter regions. -Output from processes can arrive in between bunches. */) +Output from processes can arrive in between bunches. + +If PROCESS is a non-blocking network process that hasn't been fully +set up yet, this function will block until socket setup has completed. */) (Lisp_Object process, Lisp_Object start, Lisp_Object end) { Lisp_Object proc = get_process (process); @@ -6277,7 +6290,10 @@ PROCESS may be a process, a buffer, the name of a process or buffer, or nil, indicating the current buffer's process. If STRING is more than 500 characters long, it is sent in several bunches. This may happen even for shorter strings. -Output from processes can arrive in between bunches. */) +Output from processes can arrive in between bunches. + +If PROCESS is a non-blocking network process that hasn't been fully +set up yet, this function will block until socket setup has completed. */) (Lisp_Object process, Lisp_Object string) { Lisp_Object proc; @@ -7151,7 +7167,10 @@ DEFUN ("set-process-coding-system", Fset_process_coding_system, Sset_process_coding_system, 1, 3, 0, doc: /* Set coding systems of PROCESS to DECODING and ENCODING. DECODING will be used to decode subprocess output and ENCODING to -encode subprocess input. */) +encode subprocess input. + +If PROCESS is a non-blocking network process that hasn't been fully +set up yet, this function will block until socket setup has completed. */) (register Lisp_Object process, Lisp_Object decoding, Lisp_Object encoding) { register struct Lisp_Process *p; commit fc4457d7143c44514810b971e103daedcea404ec Author: Lars Ingebrigtsen Date: Mon Feb 22 13:07:27 2016 +1100 Add blocker warnings to the *Messages* buffer * src/process.c (wait_for_socket_fds): Add warning to the log. (wait_while_connecting): Ditto. (wait_for_tls_negotiation): Ditto. diff --git a/src/process.c b/src/process.c index 1f83327..79f8072 100644 --- a/src/process.c +++ b/src/process.c @@ -4733,7 +4733,7 @@ wait_for_socket_fds (Lisp_Object process, char *name) while (XPROCESS (process)->infd < 0 && EQ (XPROCESS (process)->status, Qconnect)) { - printf("Waiting for socket from %s...\n", name); + add_to_log ("Waiting for socket from %s...\n", name); wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0); } } @@ -4743,7 +4743,7 @@ wait_while_connecting (Lisp_Object process) { while (EQ (XPROCESS (process)->status, Qconnect)) { - printf("Waiting for connection...\n"); + add_to_log ("Waiting for connection...\n"); wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0); } } @@ -4755,7 +4755,7 @@ wait_for_tls_negotiation (Lisp_Object process) while (XPROCESS (process)->gnutls_p && XPROCESS (process)->gnutls_initstage != GNUTLS_STAGE_READY) { - printf("Waiting for TLS...\n"); + add_to_log ("Waiting for TLS...\n"); wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0); } #endif commit 3007b422b69f7b1660379b5d8e6713e8b823c098 Author: Lars Ingebrigtsen Date: Mon Feb 22 12:50:40 2016 +1100 Rework the image property getter/setters * doc/lispref/display.texi (Defining Images): Document the renamed `image-get/set-property' functions. * lisp/image.el (image--set-property): Rename from image-set-property. (image-property): Declare a setf form. (image-property): Rename from `image-get-property'. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 3758ddf..c49cca2 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -5444,19 +5444,17 @@ If none of the alternatives will work, then @var{symbol} is defined as @code{nil}. @end defmac -@defun image-set-property image property value -Set the value of @var{property} in @var{image} to @var{value}. If -@var{value} is @code{nil}, the property is removed completely. +@defun image-property image property +Return the value of @var{property} in @var{image}. Properties can be +set by using @code{setf}. Setting a property to @code{nil} will +remove the property from the image. +@end defun @lisp (image-set-property image :height 300) @end lisp @end defun -@defun image-get-property image property -Return the value of @var{property} in @var{image}. -@end defun - @defun find-image specs This function provides a convenient way to find an image satisfying one of a list of image specifications @var{specs}. diff --git a/etc/NEWS b/etc/NEWS index 9a3799a..4532a18 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -865,8 +865,8 @@ added. See the "SVG Images" section in the lispref manual for details. +++ -*** New functions to access and set image parameters are provided: -`image-get-property' and `image-set-property'. +*** New setf-able function to access and set image parameters is +provided: `image-property'. ** Lisp mode diff --git a/lisp/image.el b/lisp/image.el index 3522c5b..96afa98 100644 --- a/lisp/image.el +++ b/lisp/image.el @@ -435,10 +435,9 @@ Image file names that are not absolute are searched for in the (image-compute-scaling-factor image-scaling-factor))) props))) -(defun image-set-property (image property value) +(defun image--set-property (image property value) "Set PROPERTY in IMAGE to VALUE. -If VALUE is nil, PROPERTY is removed from IMAGE. IMAGE is -returned." +Internal use only." (if (null value) (while (cdr image) ;; IMAGE starts with the symbol `image', and the rest is a @@ -451,8 +450,13 @@ returned." (plist-put (cdr image) property value)) image) -(defun image-get-property (image property) - "Return the value of PROPERTY in IMAGE." +(defun image-property (image property) + "Return the value of PROPERTY in IMAGE. +Properties can be set with + + (setf (image-property IMAGE PROPERTY) VALUE) +If VALUE is nil, PROPERTY is removed from IMAGE." + (declare (gv-setter image--set-property)) (plist-get (cdr image) property)) (defun image-compute-scaling-factor (scaling) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 6352d38..4c3dfc4 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -1536,7 +1536,7 @@ The preference is a float determined from `shr-prefer-media-type'." (- (nth 2 edges) (nth 0 edges)))))) (max-height (and edges (truncate (* shr-max-image-proportion - (- (nth 3 edges) (nth 1 edges)))))) + (- (nth 3 edges) (nth 1 edges)))))) svg image) (when (and max-width (> width max-width)) @@ -1551,7 +1551,8 @@ The preference is a float determined from `shr-prefer-media-type'." (svg-rectangle svg 0 0 width height :gradient "background" :stroke-width 2 :stroke-color "black") (let ((image (svg-image svg))) - (image-set-property image :ascent 100)))) + (setf (image-property image :ascent) 100) + image))) (defun shr-tag-pre (dom) (let ((shr-folding-mode 'none) commit 1f7feecaee0ed3fb79758fe60020aefb30d9ff01 Author: Paul Eggert Date: Sun Feb 21 13:25:24 2016 -0800 Use Gnulib filevercmp for version comparison * admin/merge-gnulib (GNULIB_MODULES): Add filevercmp. * doc/lispref/strings.texi (Text Comparison): * etc/NEWS, src/fns.c: * test/src/fns-tests.el (fns-tests-string-version-lessp): Rename newly-introduced function to string-version-lessp, by analogy with strverscmp. * lib/filevercmp.c, lib/filevercmp.h: New files, copied from gnulib. * lib/gnulib.mk, m4/gnulib-comp.m4: Regenerate. * src/fns.c: Include . (gather_number_from_string): Remove. (Fstring_version_lessp): Reimplement via filevercmp. diff --git a/admin/merge-gnulib b/admin/merge-gnulib index 5463d1b..5d65127 100755 --- a/admin/merge-gnulib +++ b/admin/merge-gnulib @@ -30,7 +30,7 @@ GNULIB_MODULES=' careadlinkat close-stream count-one-bits count-trailing-zeros crypto/md5 crypto/sha1 crypto/sha256 crypto/sha512 dtoastr dtotimespec dup2 environ execinfo faccessat - fcntl fcntl-h fdatasync fdopendir filemode fstatat fsync + fcntl fcntl-h fdatasync fdopendir filemode filevercmp fstatat fsync getloadavg getopt-gnu gettime gettimeofday gitlog-to-changelog ignore-value intprops largefile lstat manywarnings memrchr mkostemp mktime diff --git a/doc/lispref/strings.texi b/doc/lispref/strings.texi index 19301de..ce629aa 100644 --- a/doc/lispref/strings.texi +++ b/doc/lispref/strings.texi @@ -633,20 +633,12 @@ If your system does not support a locale environment, this function behaves like @code{string-lessp}. @end defun -@defun string-numerical-lessp strin1 string2 -This function behaves like @code{string-lessp} for stretches of -consecutive non-numerical characters, but compares sequences of -numerical characters as if they comprised a base-ten number, and then -compares the numbers. So @samp{foo2.png} is ``smaller'' than -@samp{foo12.png} according to this predicate, even if @samp{12} is -lexicographically ``smaller'' than @samp{2}. - -If one string has a number in a position in the string, and the other -doesn't, then lexicograpic comparison is done at that point, so -@samp{foo.png} is ``smaller'' than @samp{foo2.png}. If any of the -numbers in the strings are larger than can be represented as an -integer number, the entire string is compared using -@code{string-less}. +@defun string-version-lessp string1 string2 +This function compares strings lexicographically, except it treats +sequences of numerical characters as if they comprised a base-ten +number, and then compares the numbers. So @samp{foo2.png} is +``smaller'' than @samp{foo12.png} according to this predicate, even if +@samp{12} is lexicographically ``smaller'' than @samp{2}. @end defun @defun string-prefix-p string1 string2 &optional ignore-case diff --git a/etc/NEWS b/etc/NEWS index bad9519..9a3799a 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1726,7 +1726,7 @@ systems and for MS-Windows, for other systems they fall back to their counterparts `string-lessp' and `string-equal'. +++ -** The new function `string-numeric-lessp' compares strings by +** The new function `string-version-lessp' compares strings by interpreting consecutive runs of numerical characters as numbers, and compares their numerical values. According to this predicate, "foo2.png" is smaller than "foo12.png". diff --git a/lib/filevercmp.c b/lib/filevercmp.c new file mode 100644 index 0000000..a75c946 --- /dev/null +++ b/lib/filevercmp.c @@ -0,0 +1,181 @@ +/* + Copyright (C) 1995 Ian Jackson + Copyright (C) 2001 Anthony Towns + Copyright (C) 2008-2016 Free Software Foundation, Inc. + + This program 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. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +#include +#include "filevercmp.h" + +#include +#include +#include +#include +#include +#include + +/* Match a file suffix defined by this regular expression: + /(\.[A-Za-z~][A-Za-z0-9~]*)*$/ + Scan the string *STR and return a pointer to the matching suffix, or + NULL if not found. Upon return, *STR points to terminating NUL. */ +static const char * +match_suffix (const char **str) +{ + const char *match = NULL; + bool read_alpha = false; + while (**str) + { + if (read_alpha) + { + read_alpha = false; + if (!c_isalpha (**str) && '~' != **str) + match = NULL; + } + else if ('.' == **str) + { + read_alpha = true; + if (!match) + match = *str; + } + else if (!c_isalnum (**str) && '~' != **str) + match = NULL; + (*str)++; + } + return match; +} + +/* verrevcmp helper function */ +static int +order (unsigned char c) +{ + if (c_isdigit (c)) + return 0; + else if (c_isalpha (c)) + return c; + else if (c == '~') + return -1; + else + return (int) c + UCHAR_MAX + 1; +} + +/* slightly modified verrevcmp function from dpkg + S1, S2 - compared string + S1_LEN, S2_LEN - length of strings to be scanned + + This implements the algorithm for comparison of version strings + specified by Debian and now widely adopted. The detailed + specification can be found in the Debian Policy Manual in the + section on the 'Version' control field. This version of the code + implements that from s5.6.12 of Debian Policy v3.8.0.1 + http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Version */ +static int _GL_ATTRIBUTE_PURE +verrevcmp (const char *s1, size_t s1_len, const char *s2, size_t s2_len) +{ + size_t s1_pos = 0; + size_t s2_pos = 0; + while (s1_pos < s1_len || s2_pos < s2_len) + { + int first_diff = 0; + while ((s1_pos < s1_len && !c_isdigit (s1[s1_pos])) + || (s2_pos < s2_len && !c_isdigit (s2[s2_pos]))) + { + int s1_c = (s1_pos == s1_len) ? 0 : order (s1[s1_pos]); + int s2_c = (s2_pos == s2_len) ? 0 : order (s2[s2_pos]); + if (s1_c != s2_c) + return s1_c - s2_c; + s1_pos++; + s2_pos++; + } + while (s1[s1_pos] == '0') + s1_pos++; + while (s2[s2_pos] == '0') + s2_pos++; + while (c_isdigit (s1[s1_pos]) && c_isdigit (s2[s2_pos])) + { + if (!first_diff) + first_diff = s1[s1_pos] - s2[s2_pos]; + s1_pos++; + s2_pos++; + } + if (c_isdigit (s1[s1_pos])) + return 1; + if (c_isdigit (s2[s2_pos])) + return -1; + if (first_diff) + return first_diff; + } + return 0; +} + +/* Compare version strings S1 and S2. + See filevercmp.h for function description. */ +int +filevercmp (const char *s1, const char *s2) +{ + const char *s1_pos; + const char *s2_pos; + const char *s1_suffix, *s2_suffix; + size_t s1_len, s2_len; + int result; + + /* easy comparison to see if strings are identical */ + int simple_cmp = strcmp (s1, s2); + if (simple_cmp == 0) + return 0; + + /* special handle for "", "." and ".." */ + if (!*s1) + return -1; + if (!*s2) + return 1; + if (0 == strcmp (".", s1)) + return -1; + if (0 == strcmp (".", s2)) + return 1; + if (0 == strcmp ("..", s1)) + return -1; + if (0 == strcmp ("..", s2)) + return 1; + + /* special handle for other hidden files */ + if (*s1 == '.' && *s2 != '.') + return -1; + if (*s1 != '.' && *s2 == '.') + return 1; + if (*s1 == '.' && *s2 == '.') + { + s1++; + s2++; + } + + /* "cut" file suffixes */ + s1_pos = s1; + s2_pos = s2; + s1_suffix = match_suffix (&s1_pos); + s2_suffix = match_suffix (&s2_pos); + s1_len = (s1_suffix ? s1_suffix : s1_pos) - s1; + s2_len = (s2_suffix ? s2_suffix : s2_pos) - s2; + + /* restore file suffixes if strings are identical after "cut" */ + if ((s1_suffix || s2_suffix) && (s1_len == s2_len) + && 0 == strncmp (s1, s2, s1_len)) + { + s1_len = s1_pos - s1; + s2_len = s2_pos - s2; + } + + result = verrevcmp (s1, s1_len, s2, s2_len); + return result == 0 ? simple_cmp : result; +} diff --git a/lib/filevercmp.h b/lib/filevercmp.h new file mode 100644 index 0000000..220b71b --- /dev/null +++ b/lib/filevercmp.h @@ -0,0 +1,42 @@ +/* + Copyright (C) 1995 Ian Jackson + Copyright (C) 2001 Anthony Towns + Copyright (C) 2008-2016 Free Software Foundation, Inc. + + This program 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. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +#ifndef FILEVERCMP_H +#define FILEVERCMP_H + +/* Compare version strings: + + This function compares strings S1 and S2: + 1) By PREFIX in the same way as strcmp. + 2) Then by VERSION (most similarly to version compare of Debian's dpkg). + Leading zeros in version numbers are ignored. + 3) If both (PREFIX and VERSION) are equal, strcmp function is used for + comparison. So this function can return 0 if (and only if) strings S1 + and S2 are identical. + + It returns number >0 for S1 > S2, 0 for S1 == S2 and number <0 for S1 < S2. + + This function compares strings, in a way that if VER1 and VER2 are version + numbers and PREFIX and SUFFIX (SUFFIX defined as (\.[A-Za-z~][A-Za-z0-9~]*)*) + are strings then VER1 < VER2 implies filevercmp (PREFIX VER1 SUFFIX, + PREFIX VER2 SUFFIX) < 0. + + This function is intended to be a replacement for strverscmp. */ +int filevercmp (const char *s1, const char *s2) _GL_ATTRIBUTE_PURE; + +#endif /* FILEVERCMP_H */ diff --git a/lib/gnulib.mk b/lib/gnulib.mk index b1edd86..cc84296 100644 --- a/lib/gnulib.mk +++ b/lib/gnulib.mk @@ -21,7 +21,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=close --avoid=dup --avoid=fchdir --avoid=flexmember --avoid=fstat --avoid=malloc-posix --avoid=msvc-inval --avoid=msvc-nothrow --avoid=open --avoid=openat-die --avoid=opendir --avoid=raise --avoid=save-cwd --avoid=select --avoid=setenv --avoid=sigprocmask --avoid=stdarg --avoid=stdbool --avoid=threadlib --avoid=unsetenv --makefile-name=gnulib.mk --conditional-dependencies --no-libtool --macro-prefix=gl --no-vc-files alloca-opt binary-io byteswap c-ctype c-strcase careadlinkat close-stream count-one-bits count-trailing-zeros crypto/md5 crypto/sha1 crypto/sha256 crypto/sha512 dtoastr dtotimespec dup2 environ execinfo faccessat fcntl fcntl-h fdatasync fdopendir filemode fstatat fsync getloadavg getopt-gnu gettime gettimeofday gitlog-to-changelog ignore-value intprops largefile lstat manywarnings memrchr mkostemp mktime pipe2 pselect pthread_sigmask putenv qcopy-acl readlink readlinkat sig2str socklen stat-time std-gnu11 stdalign stddef stdio stpcpy strftime strtoimax strtoumax symlink sys_stat sys_time time time_r time_rz timegm timer-time timespec-add timespec-sub unsetenv update-copyright utimens vla warnings +# Reproduce by: gnulib-tool --import --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=close --avoid=dup --avoid=fchdir --avoid=flexmember --avoid=fstat --avoid=malloc-posix --avoid=msvc-inval --avoid=msvc-nothrow --avoid=open --avoid=openat-die --avoid=opendir --avoid=raise --avoid=save-cwd --avoid=select --avoid=setenv --avoid=sigprocmask --avoid=stdarg --avoid=stdbool --avoid=threadlib --avoid=unsetenv --makefile-name=gnulib.mk --conditional-dependencies --no-libtool --macro-prefix=gl --no-vc-files alloca-opt binary-io byteswap c-ctype c-strcase careadlinkat close-stream count-one-bits count-trailing-zeros crypto/md5 crypto/sha1 crypto/sha256 crypto/sha512 dtoastr dtotimespec dup2 environ execinfo faccessat fcntl fcntl-h fdatasync fdopendir filemode filevercmp fstatat fsync getloadavg getopt-gnu gettime gettimeofday gitlog-to-changelog ignore-value intprops largefile lstat manywarnings memrchr mkostemp mktime pipe2 pselect pthread_sigmask putenv qcopy-acl readlink readlinkat sig2str socklen stat-time std-gnu11 stdalign stddef stdio stpcpy strftime strtoimax strtoumax symlink sys_stat sys_time time time_r time_rz timegm timer-time timespec-add timespec-sub unsetenv update-copyright utimens vla warnings MOSTLYCLEANFILES += core *.stackdump @@ -441,6 +441,14 @@ EXTRA_DIST += filemode.h ## end gnulib module filemode +## begin gnulib module filevercmp + +libgnu_a_SOURCES += filevercmp.c + +EXTRA_DIST += filevercmp.h + +## end gnulib module filevercmp + ## begin gnulib module fpending diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index 831bb4c..5a3fc98 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -78,6 +78,7 @@ AC_DEFUN([gl_EARLY], # Code from module fdatasync: # Code from module fdopendir: # Code from module filemode: + # Code from module filevercmp: # Code from module fpending: # Code from module fstatat: # Code from module fsync: @@ -889,6 +890,8 @@ AC_DEFUN([gl_FILE_LIST], [ lib/fdopendir.c lib/filemode.c lib/filemode.h + lib/filevercmp.c + lib/filevercmp.h lib/fpending.c lib/fpending.h lib/fstatat.c diff --git a/src/fns.c b/src/fns.c index 77ad450..d314fcd 100644 --- a/src/fns.c +++ b/src/fns.c @@ -21,6 +21,7 @@ along with GNU Emacs. If not, see . */ #include #include +#include #include #include #include @@ -332,50 +333,21 @@ Symbols are also allowed; their print names are used instead. */) return i1 < SCHARS (string2) ? Qt : Qnil; } -/* Return the numerical value of a consecutive run of numerical - characters from STRING. The ISP and ISP_BYTE address pointer - pointers are increased and left at the next character after the - numerical characters. */ -static size_t -gather_number_from_string (Lisp_Object string, - ptrdiff_t *isp, ptrdiff_t *isp_byte) -{ - size_t number = 0; - char *s = SSDATA (string); - char *end; - - errno = 0; - number = strtoumax (s + *isp_byte, &end, 10); - if (errno == ERANGE) - /* If we have an integer overflow, then we fall back on lexical - comparison. */ - return -1; - else - { - size_t diff = end - (s + *isp_byte); - (*isp) += diff; - (*isp_byte) += diff; - return number; - } -} +DEFUN ("string-version-lessp", Fstring_version_lessp, + Sstring_version_lessp, 2, 2, 0, + doc: /* Return non-nil if S1 is less than S2, as version strings. + +This function compares version strings S1 and S2: + 1) By prefix lexicographically. + 2) Then by version (similarly to version comparison of Debian's dpkg). + Leading zeros in version numbers are ignored. + 3) If both prefix and version are equal, compare as ordinary strings. -DEFUN ("string-numeric-lessp", Fstring_numeric_lessp, - Sstring_numeric_lessp, 2, 2, 0, - doc: /* Return non-nil if STRING1 is less than STRING2 in 'numeric' order. -Sequences of non-numerical characters are compared lexicographically, -while sequences of numerical characters are converted into numbers, -and then the numbers are compared. This means that \"foo2.png\" is -less than \"foo12.png\" according to this predicate. +For example, \"foo2.png\" compares less than \"foo12.png\". Case is significant. Symbols are also allowed; their print names are used instead. */) - (register Lisp_Object string1, Lisp_Object string2) + (Lisp_Object string1, Lisp_Object string2) { - ptrdiff_t end; - ptrdiff_t i1, i1_byte, i2, i2_byte; - size_t num1, num2; - unsigned char *chp; - int chlen1, chlen2; - if (SYMBOLP (string1)) string1 = SYMBOL_NAME (string1); if (SYMBOLP (string2)) @@ -383,67 +355,26 @@ Symbols are also allowed; their print names are used instead. */) CHECK_STRING (string1); CHECK_STRING (string2); - i1 = i1_byte = i2 = i2_byte = 0; + char *p1 = SSDATA (string1); + char *p2 = SSDATA (string2); + char *lim1 = p1 + SBYTES (string1); + char *lim2 = p2 + SBYTES (string2); + int cmp; - end = SCHARS (string1); - if (end > SCHARS (string2)) - end = SCHARS (string2); - - while (i1 < end) + while ((cmp = filevercmp (p1, p2)) == 0) { - /* When we find a mismatch, we must compare the - characters, not just the bytes. */ - int c1, c2; - - if (STRING_MULTIBYTE (string1)) - { - chp = &SDATA (string1)[i1_byte]; - c1 = STRING_CHAR_AND_LENGTH (chp, chlen1); - } - else - { - c1 = SREF (string1, i1_byte); - chlen1 = 1; - } - - if (STRING_MULTIBYTE (string2)) - { - chp = &SDATA (string1)[i2_byte]; - c2 = STRING_CHAR_AND_LENGTH (chp, chlen2); - } - else - { - c2 = SREF (string2, i2_byte); - chlen2 = 1; - } - - if (c1 >= '0' && c1 <= '9' && - c2 >= '0' && c2 <= '9') - /* Both strings are numbers, so compare them. */ - { - num1 = gather_number_from_string (string1, &i1, &i1_byte); - num2 = gather_number_from_string (string2, &i2, &i2_byte); - /* If we have an integer overflow, then resort to sorting - the entire string lexicographically. */ - if (num1 == -1 || num2 == -1) - return Fstring_lessp (string1, string2); - else if (num1 < num2) - return Qt; - else if (num1 > num2) - return Qnil; - } - else - { - if (c1 != c2) - return c1 < c2 ? Qt : Qnil; - - i1++; - i2++; - i1_byte += chlen1; - i2_byte += chlen2; - } + /* If the strings are identical through their first null bytes, + skip past identical prefixes and try again. */ + ptrdiff_t size = strlen (p1) + 1; + p1 += size; + p2 += size; + if (lim1 < p1) + return lim2 < p2 ? Qnil : Qt; + if (lim2 < p2) + return Qnil; } - return i1 < SCHARS (string2) ? Qt : Qnil; + + return cmp < 0 ? Qt : Qnil; } DEFUN ("string-collate-lessp", Fstring_collate_lessp, Sstring_collate_lessp, 2, 4, 0, @@ -5164,7 +5095,7 @@ this variable. */); defsubr (&Sstring_equal); defsubr (&Scompare_strings); defsubr (&Sstring_lessp); - defsubr (&Sstring_numeric_lessp); + defsubr (&Sstring_version_lessp); defsubr (&Sstring_collate_lessp); defsubr (&Sstring_collate_equalp); defsubr (&Sappend); diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index 0c6edb8..8617369 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -192,19 +192,19 @@ a b (if (eq system-type 'windows-nt) "enu_USA" "en_US.UTF-8"))))) '("Adrian" "Ævar" "Agustín" "Eli")))) -(ert-deftest fns-tests-string-numeric-lessp () - (should (string-numeric-lessp "foo2.png" "foo12.png")) - (should (not (string-numeric-lessp "foo12.png" "foo2.png"))) - (should (string-numeric-lessp "foo12.png" "foo20000.png")) - (should (not (string-numeric-lessp "foo20000.png" "foo12.png"))) - (should (string-numeric-lessp "foo.png" "foo2.png")) - (should (not (string-numeric-lessp "foo2.png" "foo.png"))) +(ert-deftest fns-tests-string-version-lessp () + (should (string-version-lessp "foo2.png" "foo12.png")) + (should (not (string-version-lessp "foo12.png" "foo2.png"))) + (should (string-version-lessp "foo12.png" "foo20000.png")) + (should (not (string-version-lessp "foo20000.png" "foo12.png"))) + (should (string-version-lessp "foo.png" "foo2.png")) + (should (not (string-version-lessp "foo2.png" "foo.png"))) (should (equal (sort '("foo12.png" "foo2.png" "foo1.png") - 'string-numeric-lessp) + 'string-version-lessp) '("foo1.png" "foo2.png" "foo12.png"))) - (should (string-numeric-lessp "foo2" "foo1234")) - (should (not (string-numeric-lessp "foo1234" "foo2"))) - (should (string-numeric-lessp "foo.png" "foo2")) - (should (string-numeric-lessp "foo1.25.5.png" "foo1.125.5")) - (should (string-numeric-lessp "2" "1245")) - (should (not (string-numeric-lessp "1245" "2")))) + (should (string-version-lessp "foo2" "foo1234")) + (should (not (string-version-lessp "foo1234" "foo2"))) + (should (string-version-lessp "foo.png" "foo2")) + (should (string-version-lessp "foo1.25.5.png" "foo1.125.5")) + (should (string-version-lessp "2" "1245")) + (should (not (string-version-lessp "1245" "2")))) commit c8bcb0bb1af86f2e55dc10e243ad8a0e4f69ed24 Author: Lars Ingebrigtsen Date: Sun Feb 21 14:08:17 2016 +1100 Clarify levels of :nowait t. * doc/lispref/processes.texi (Network Processes): Mention levels of asynchronicity. diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index 60b2d90..8234501 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -2409,14 +2409,22 @@ as it may depend on implementation defined constants, data sizes, and data structure alignment. @end itemize -@item :nowait @var{nowait} -If @var{nowait} is non-@code{nil} for a stream connection, return +@item :nowait @var{bool} +If @var{bool} is non-@code{nil} for a stream connection, return 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. @item :tls-parameters When opening a TLS connection, this should be where the first element commit 799367921033a9bfca27109ba934cb2981c436f9 Author: Alain Schneble Date: Sun Feb 21 13:36:25 2016 +1100 Respect DNS timeouts * src/process.c (check_for_dns): If the async DNS request failed and the associated process is still in "connect" state, deactivate the process and set status to "failed". diff --git a/src/process.c b/src/process.c index a59e418..1f83327 100644 --- a/src/process.c +++ b/src/process.c @@ -4706,7 +4706,7 @@ check_for_dns (Lisp_Object proc) ip_addresses = Fnreverse (ip_addresses); } /* The DNS lookup failed. */ - else if (!EQ (p->status, Qconnect)) + else if (EQ (p->status, Qconnect)) { deactivate_process (proc); pset_status (p, (list2 commit 7d63fa01afef49ee53c742cd6b8cb86d14911fa3 Author: Lars Ingebrigtsen Date: Fri Feb 19 12:37:34 2016 +1100 Fix up tests for async TLS negotiation diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el index a50c7f0..e19bd52 100644 --- a/test/lisp/net/network-stream-tests.el +++ b/test/lisp/net/network-stream-tests.el @@ -37,7 +37,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" @@ -51,7 +51,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" @@ -144,9 +144,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) @@ -155,17 +152,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) @@ -178,7 +175,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) @@ -194,10 +191,46 @@ (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)) - (let ((server (make-tls-server)) + (let ((server (make-tls-server 44333)) (times 0) proc status) (sleep-for 1) @@ -211,14 +244,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)) commit b73e5254ea9056ee2088ed096ef1de3ef8699855 Author: Lars Ingebrigtsen Date: Fri Feb 19 11:58:50 2016 +1100 Fix coding system setup * src/process.c (set_network_socket_coding_system): Pass in the host/service that's been computed already. diff --git a/src/process.c b/src/process.c index 4a11e7f..a59e418 100644 --- a/src/process.c +++ b/src/process.c @@ -2945,19 +2945,17 @@ usage: (make-serial-process &rest ARGS) */) return proc; } -void set_network_socket_coding_system (Lisp_Object proc) +void set_network_socket_coding_system (Lisp_Object proc, + Lisp_Object host, + Lisp_Object service, + Lisp_Object name) { Lisp_Object tem; struct Lisp_Process *p = XPROCESS (proc); Lisp_Object contact = p->childp; - Lisp_Object service, host, name; Lisp_Object coding_systems = Qt; Lisp_Object val; - service = Fplist_get (contact, QCservice); - host = Fplist_get (contact, QChost); - name = Fplist_get (contact, QCname); - tem = Fplist_member (contact, QCcoding); if (!NILP (tem) && (!CONSP (tem) || !CONSP (XCDR (tem)))) tem = Qnil; /* No error message (too late!). */ @@ -3931,7 +3929,7 @@ usage: (make-network-process &rest ARGS) */) p->gnutls_boot_parameters = tem; #endif - set_network_socket_coding_system (proc); + set_network_socket_coding_system (proc, service, host, name); unbind_to (count, Qnil); commit e96df838aff3e1432d68cb0ed1fa899f79a70847 Author: Lars Ingebrigtsen Date: Thu Feb 18 16:25:37 2016 +1100 Verify the TLS connection asynchronously * src/gnutls.c (gnutls_verify_boot): Refactor out into its own function so that we can call it asynchronously. (Fgnutls_boot): Use it. * src/process.c (wait_reading_process_output): Verify the TLS negotiation. diff --git a/src/gnutls.c b/src/gnutls.c index 6573c87..ce4fbf9 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -540,8 +540,6 @@ 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) return -1; @@ -1032,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. */ @@ -1176,6 +1174,149 @@ boot_error (struct Lisp_Process *p, const char *m, ...) 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. @@ -1235,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. */ @@ -1253,9 +1392,7 @@ 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); @@ -1280,19 +1417,8 @@ 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))) - { - 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)"); @@ -1521,112 +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); - 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); + return gnutls_verify_boot (proc, proplist); } DEFUN ("gnutls-bye", Fgnutls_bye, diff --git a/src/gnutls.h b/src/gnutls.h index cb52135..d03332e 100644 --- a/src/gnutls.h +++ b/src/gnutls.h @@ -85,6 +85,7 @@ extern void emacs_gnutls_transport_set_errno (gnutls_session_t state, int err); 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 diff --git a/src/process.c b/src/process.c index d78b04f..4a11e7f 100644 --- a/src/process.c +++ b/src/process.c @@ -4919,7 +4919,10 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, p->gnutls_handshakes_tried++; if (p->gnutls_initstage == GNUTLS_STAGE_READY) - finish_after_tls_connection (aproc); + { + gnutls_verify_boot (proc, Qnil); + finish_after_tls_connection (aproc); + } else if (p->gnutls_handshakes_tried > GNUTLS_EMACS_HANDSHAKES_LIMIT) { commit d4bb0b923b30c78ea18e4744c7a9ab6f3f2c4b1b Author: Lars Ingebrigtsen Date: Tue Feb 16 16:47:55 2016 +1100 Deactivate the correct process * src/process.c (wait_reading_process_output): Deactivate the correct process on failure. diff --git a/src/process.c b/src/process.c index ec31ea8..d78b04f 100644 --- a/src/process.c +++ b/src/process.c @@ -4923,7 +4923,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, else if (p->gnutls_handshakes_tried > GNUTLS_EMACS_HANDSHAKES_LIMIT) { - deactivate_process (proc); + deactivate_process (aproc); pset_status (p, list2 (Qfailed, build_string ("TLS negotiation failed"))); } commit ac6e085cf6b26257cfe181f17828432d414cb3a6 Author: Lars Ingebrigtsen Date: Tue Feb 16 15:56:56 2016 +1100 Implement asynch TLS negotiation * src/gnutls.c (gnutls_try_handshake): Factor out into its own function. (emacs_gnutls_handshake): Use it. (emacs_gnutls_read): Just return instead of retrying the handshake. * src/process.c (finish_after_tls_connection): Factor out into its own function. (connect_network_socket): Use it. (wait_reading_process_output): Retry TLS handshakes. (wait_reading_process_output): Defer sentinel until TLS completes. diff --git a/src/gnutls.c b/src/gnutls.c index 948a0c5..6573c87 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -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 @@ -531,23 +543,8 @@ emacs_gnutls_read (struct Lisp_Process *proc, char *buf, ptrdiff_t nbyte) 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; diff --git a/src/gnutls.h b/src/gnutls.h index 8e879c1..cb52135 100644 --- a/src/gnutls.h +++ b/src/gnutls.h @@ -84,6 +84,7 @@ 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); #endif diff --git a/src/process.c b/src/process.c index 9a3bcae..ec31ea8 100644 --- a/src/process.c +++ b/src/process.c @@ -281,9 +281,7 @@ static int max_input_desc; /* Indexed by descriptor, gives the process (if any) for that descriptor. */ static Lisp_Object chan_process[FD_SETSIZE]; -#ifdef HAVE_GETADDRINFO_A static void wait_for_socket_fds (Lisp_Object process, char *name); -#endif /* Alist of elements (NAME . PROCESS). */ static Lisp_Object Vprocess_alist; @@ -3038,7 +3036,45 @@ void set_network_socket_coding_system (Lisp_Object proc) = !(!NILP (tem) || NILP (p->buffer) || !inherit_process_coding_system); } -void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) +#ifdef HAVE_GNUTLS +void +finish_after_tls_connection (Lisp_Object proc) +{ + struct Lisp_Process *p = XPROCESS (proc); + Lisp_Object contact = p->childp; + Lisp_Object result = Qt; + + if (!NILP (Ffboundp (Qnsm_verify_connection))) + result = call3 (Qnsm_verify_connection, + proc, + Fplist_get (contact, QChost), + Fplist_get (contact, QCservice)); + + if (NILP (result)) + { + pset_status (p, list2 (Qfailed, + build_string ("The Network Security Manager stopped the connections"))); + deactivate_process (proc); + } + else + { + /* If we cleared the connection wait mask before we did + the TLS setup, then we have to say that the process + is finally "open" here. */ + if (! FD_ISSET (p->outfd, &connect_wait_mask)) + { + pset_status (p, Qrun); + /* Execute the sentinel here. If we had relied on + status_notify to do it later, it will read input + from the process before calling the sentinel. */ + exec_sentinel (proc, build_string ("open\n")); + } + } +} +#endif + +void +connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) { ptrdiff_t count = SPECPDL_INDEX (); ptrdiff_t count1; @@ -3359,8 +3395,10 @@ void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) boot = Fgnutls_boot (proc, XCAR (params), XCDR (params)); p->gnutls_boot_parameters = Qnil; - if (NILP (boot) || STRINGP (boot) || - p->gnutls_initstage != GNUTLS_STAGE_READY) + if (p->gnutls_initstage == GNUTLS_STAGE_READY) + /* Run sentinels, etc. */ + finish_after_tls_connection (proc); + else if (p->gnutls_initstage != GNUTLS_STAGE_HANDSHAKE_TRIED) { deactivate_process (proc); if (NILP (boot)) @@ -3369,37 +3407,6 @@ void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) else pset_status (p, list2 (Qfailed, boot)); } - else - { - Lisp_Object result = Qt; - - if (!NILP (Ffboundp (Qnsm_verify_connection))) - result = call3 (Qnsm_verify_connection, - proc, - Fplist_get (contact, QChost), - Fplist_get (contact, QCservice)); - - if (NILP (result)) - { - pset_status (p, list2 (Qfailed, - build_string ("The Network Security Manager stopped the connections"))); - deactivate_process (proc); - } - else - { - /* If we cleared the connection wait mask before we did - the TLS setup, then we have to say that the process - is finally "open" here. */ - if (! FD_ISSET (p->outfd, &connect_wait_mask)) - { - pset_status (p, Qrun); - /* Execute the sentinel here. If we had relied on - status_notify to do it later, it will read input - from the process before calling the sentinel. */ - exec_sentinel (proc, build_string ("open\n")); - } - } - } } #endif @@ -4747,8 +4754,8 @@ static void wait_for_tls_negotiation (Lisp_Object process) { #ifdef HAVE_GNUTLS - while (EQ (XPROCESS (process)->status, Qconnect) && - !NILP (XPROCESS (process)->gnutls_boot_parameters)) + while (XPROCESS (process)->gnutls_p && + XPROCESS (process)->gnutls_initstage != GNUTLS_STAGE_READY) { printf("Waiting for TLS...\n"); wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0); @@ -4881,7 +4888,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, if (! NILP (wait_for_cell) && ! NILP (XCAR (wait_for_cell))) break; -#ifdef HAVE_GETADDRINFO_A +#if defined (HAVE_GETADDRINFO_A) || defined (HAVE_GNUTLS) { Lisp_Object ip_addresses; Lisp_Object process_list_head, aproc; @@ -4891,17 +4898,41 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, { p = XPROCESS (aproc); - if (p->dns_requests && - (! wait_proc || p == wait_proc)) + if (! wait_proc || p == wait_proc) { - ip_addresses = check_for_dns (aproc); - if (!NILP (ip_addresses) && - !EQ (ip_addresses, Qt)) - connect_network_socket (aproc, ip_addresses); +#ifdef HAVE_GETADDRINFO_A + /* Check for pending DNS requests. */ + if (p->dns_requests) + { + ip_addresses = check_for_dns (aproc); + if (!NILP (ip_addresses) && + !EQ (ip_addresses, Qt)) + connect_network_socket (aproc, ip_addresses); + } +#endif +#ifdef HAVE_GNUTLS + /* Continue TLS negotiation. */ + if (p->gnutls_initstage == GNUTLS_STAGE_HANDSHAKE_TRIED && + p->is_non_blocking_client) + { + gnutls_try_handshake (p); + p->gnutls_handshakes_tried++; + + if (p->gnutls_initstage == GNUTLS_STAGE_READY) + finish_after_tls_connection (aproc); + else if (p->gnutls_handshakes_tried > + GNUTLS_EMACS_HANDSHAKES_LIMIT) + { + deactivate_process (proc); + pset_status (p, list2 (Qfailed, + build_string ("TLS negotiation failed"))); + } + } +#endif } } } -#endif /* HAVE_GETADDRINFO_A */ +#endif /* GETADDRINFO_A or GNUTLS */ /* Compute time from now till when time limit is up. */ /* Exit if already run out. */ @@ -5522,7 +5553,13 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, } else { - if (NILP (p->gnutls_boot_parameters)) +#ifdef HAVE_GNUTLS + /* If we have an incompletely set up TLS connection, + then defer the sentinel signalling until + later. */ + if (NILP (p->gnutls_boot_parameters) && + !p->gnutls_p) +#endif { pset_status (p, Qrun); /* Execute the sentinel here. If we had relied on commit c43bb7f136ab9e9439a4b5c045040a12cbe8bda0 Author: Lars Ingebrigtsen Date: Tue Feb 16 13:58:26 2016 +1100 Simplify the DNS resolution loop a bit * src/process.c (wait_reading_process_output): Simplify the DNS resolution loop a bit. diff --git a/src/process.c b/src/process.c index fec2f5a..9a3bcae 100644 --- a/src/process.c +++ b/src/process.c @@ -4883,38 +4883,23 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, #ifdef HAVE_GETADDRINFO_A { - Lisp_Object ip_addresses, answers = Qnil, answer; - Lisp_Object process_list_head, async_dns_process_candidate; + Lisp_Object ip_addresses; + Lisp_Object process_list_head, aproc; struct Lisp_Process *p; - /* This is programmed in a somewhat awkward fashion because - calling connect_network_socket might make us end up back - here again, and we would have a race condition with - segfaults. So first go through all pending requests and see - whether we got any answers. */ - FOR_EACH_PROCESS(process_list_head, async_dns_process_candidate) + FOR_EACH_PROCESS(process_list_head, aproc) { - p = XPROCESS (async_dns_process_candidate); + p = XPROCESS (aproc); - if (p->dns_requests) + if (p->dns_requests && + (! wait_proc || p == wait_proc)) { - if (! wait_proc || p == wait_proc) - { - ip_addresses = check_for_dns (async_dns_process_candidate); - if (!EQ (ip_addresses, Qt)) - answers = Fcons (Fcons (async_dns_process_candidate, ip_addresses), answers); - } + ip_addresses = check_for_dns (aproc); + if (!NILP (ip_addresses) && + !EQ (ip_addresses, Qt)) + connect_network_socket (aproc, ip_addresses); } } - /* Then continue the connection for the successful - requests. */ - while (!NILP (answers)) - { - answer = XCAR (answers); - answers = XCDR (answers); - if (!NILP (XCDR (answer))) - connect_network_socket (XCAR (answer), XCDR (answer)); - } } #endif /* HAVE_GETADDRINFO_A */ commit d1fc5a548e5b49df40b0a8dad1f962cd01593da4 Author: Alain Schneble Date: Tue Feb 16 13:50:23 2016 +1100 Loop over the process list instead of maintaining a separate list * src/process.c: Remove declaration/definition of dns_processes list. * src/process.c (wait_reading_process_output): Loop over all processes in Vprocess_alist instead of dns_processes, to check for completed DNS requests. diff --git a/src/process.c b/src/process.c index b4a2de9..fec2f5a 100644 --- a/src/process.c +++ b/src/process.c @@ -282,8 +282,6 @@ static int max_input_desc; /* Indexed by descriptor, gives the process (if any) for that descriptor. */ static Lisp_Object chan_process[FD_SETSIZE]; #ifdef HAVE_GETADDRINFO_A -/* Pending DNS requests. */ -static Lisp_Object dns_processes; static void wait_for_socket_fds (Lisp_Object process, char *name); #endif @@ -3959,7 +3957,6 @@ usage: (make-network-process &rest ARGS) */) { p->dns_requests = dns_requests; p->status = Qconnect; - dns_processes = Fcons (proc, dns_processes); } else { @@ -4885,51 +4882,40 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, break; #ifdef HAVE_GETADDRINFO_A - if (!NILP (dns_processes)) - { - Lisp_Object dns_list = dns_processes, dns, ip_addresses, - answers = Qnil, answer, new = Qnil; - struct Lisp_Process *p; - - /* This is programmed in a somewhat awkward fashion because - calling connect_network_socket might make us end up back - here again, and we would have a race condition with - segfaults. So first go through all pending requests and see - whether we got any answers. */ - while (!NILP (dns_list)) - { - dns = XCAR (dns_list); - dns_list = XCDR (dns_list); - p = XPROCESS (dns); - if (p && p->dns_requests) - { - if (! wait_proc || p == wait_proc) - { - ip_addresses = check_for_dns (dns); - if (EQ (ip_addresses, Qt)) - new = Fcons (dns, new); - else - answers = Fcons (Fcons (dns, ip_addresses), answers); - } - else - new = Fcons (dns, new); - } - } - - /* Replace with the list of DNS requests still not responded - to. */ - dns_processes = new; + { + Lisp_Object ip_addresses, answers = Qnil, answer; + Lisp_Object process_list_head, async_dns_process_candidate; + struct Lisp_Process *p; + + /* This is programmed in a somewhat awkward fashion because + calling connect_network_socket might make us end up back + here again, and we would have a race condition with + segfaults. So first go through all pending requests and see + whether we got any answers. */ + FOR_EACH_PROCESS(process_list_head, async_dns_process_candidate) + { + p = XPROCESS (async_dns_process_candidate); - /* Then continue the connection for the successful - requests. */ - while (!NILP (answers)) - { - answer = XCAR (answers); - answers = XCDR (answers); - if (!NILP (XCDR (answer))) - connect_network_socket (XCAR (answer), XCDR (answer)); - } - } + if (p->dns_requests) + { + if (! wait_proc || p == wait_proc) + { + ip_addresses = check_for_dns (async_dns_process_candidate); + if (!EQ (ip_addresses, Qt)) + answers = Fcons (Fcons (async_dns_process_candidate, ip_addresses), answers); + } + } + } + /* Then continue the connection for the successful + requests. */ + while (!NILP (answers)) + { + answer = XCAR (answers); + answers = XCDR (answers); + if (!NILP (XCDR (answer))) + connect_network_socket (XCAR (answer), XCDR (answer)); + } + } #endif /* HAVE_GETADDRINFO_A */ /* Compute time from now till when time limit is up. */ @@ -7811,9 +7797,6 @@ init_process_emacs (void) #ifdef DATAGRAM_SOCKETS memset (datagram_address, 0, sizeof datagram_address); #endif -#ifdef HAVE_GETADDRINFO_A - dns_processes = Qnil; -#endif #if defined (DARWIN_OS) /* PTYs are broken on Darwin < 6, but are sometimes useful for interactive @@ -7901,9 +7884,6 @@ syms_of_process (void) staticpro (&Vprocess_alist); staticpro (&deleted_pid_list); -#ifdef HAVE_GETADDRINFO_A - staticpro (&dns_processes); -#endif #endif /* subprocesses */ commit 9755b75300b7c451bc79984eed2e346ce0a4ffb5 Author: Lars Ingebrigtsen Date: Tue Feb 16 13:37:33 2016 +1100 Allow setting the filter masks later * src/process.c (Fset_process_filter): Don't set the socket masks here, because we may not have a socket yet. (set_process_filter_masks): New function. (connect_network_socket): Set the filter masks here. diff --git a/src/process.c b/src/process.c index 02e19c3..b4a2de9 100644 --- a/src/process.c +++ b/src/process.c @@ -1034,6 +1034,23 @@ DEFUN ("process-mark", Fprocess_mark, Sprocess_mark, return XPROCESS (process)->mark; } +static void +set_process_filter_masks (struct Lisp_Process *p) +{ + if (EQ (p->filter, Qt) && !EQ (p->status, Qlisten)) + { + FD_CLR (p->infd, &input_wait_mask); + FD_CLR (p->infd, &non_keyboard_wait_mask); + } + else if (EQ (p->filter, Qt) + /* Network or serial process not stopped: */ + && !EQ (p->command, Qt)) + { + FD_SET (p->infd, &input_wait_mask); + FD_SET (p->infd, &non_keyboard_wait_mask); + } +} + DEFUN ("set-process-filter", Fset_process_filter, Sset_process_filter, 2, 2, 0, doc: /* Give PROCESS the filter function FILTER; nil means default. @@ -1069,23 +1086,11 @@ The string argument is normally a multibyte string, except: if (NILP (filter)) filter = Qinternal_default_process_filter; + pset_filter (p, filter); + if (p->infd >= 0) - { - if (EQ (filter, Qt) && !EQ (p->status, Qlisten)) - { - FD_CLR (p->infd, &input_wait_mask); - FD_CLR (p->infd, &non_keyboard_wait_mask); - } - else if (EQ (p->filter, Qt) - /* Network or serial process not stopped: */ - && !EQ (p->command, Qt)) - { - FD_SET (p->infd, &input_wait_mask); - FD_SET (p->infd, &non_keyboard_wait_mask); - } - } + set_process_filter_masks (p); - pset_filter (p, filter); if (NETCONN1_P (p) || SERIALCONN1_P (p) || PIPECONN1_P (p)) pset_childp (p, Fplist_put (p->childp, QCfilter, filter)); setup_process_coding_systems (process); @@ -3342,6 +3347,9 @@ void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) if (inch > max_process_desc) max_process_desc = inch; + /* Set up the masks based on the process filter. */ + set_process_filter_masks (p); + setup_process_coding_systems (proc); #ifdef HAVE_GNUTLS commit 1bbffcd9d70793ede66d74d6cccb5f6734893e36 Author: Lars Ingebrigtsen Date: Tue Feb 16 13:24:47 2016 +1100 Remove debugging diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el index 2b552df..d898368 100644 --- a/lisp/url/url-gw.el +++ b/lisp/url/url-gw.el @@ -256,7 +256,6 @@ overriding the value of `url-gateway-method'." (_ (error "Bad setting of url-gateway-method: %s" url-gateway-method)))))) - (message "Coding system: %s" (process-coding-system conn)) conn))) (provide 'url-gw) commit df91173405f97075e939fa7072f941d7d59c785d Author: Lars Ingebrigtsen Date: Tue Feb 16 13:23:15 2016 +1100 Ensure we always free DNS resources when deleting a process * src/process.c (free_dns_request): Factor out into own function. (Fdelete_process): When deleting a process, free any DNS structures associated with it. (check_for_dns): Always free all DNS resources. diff --git a/src/process.c b/src/process.c index 9c09aee..02e19c3 100644 --- a/src/process.c +++ b/src/process.c @@ -743,6 +743,23 @@ remove_process (register Lisp_Object proc) deactivate_process (proc); } +#ifdef HAVE_GETADDRINFO_A +static void +free_dns_request (Lisp_Object proc) +{ + struct Lisp_Process *p = XPROCESS (proc); + + if (p->dns_requests[0]->ar_result) + freeaddrinfo (p->dns_requests[0]->ar_result); + xfree ((void *)p->dns_requests[0]->ar_request); + xfree ((void *)p->dns_requests[0]->ar_name); + xfree ((void *)p->dns_requests[0]->ar_service); + xfree (p->dns_requests[0]); + xfree (p->dns_requests); + p->dns_requests = NULL; +} +#endif + DEFUN ("processp", Fprocessp, Sprocessp, 1, 1, 0, doc: /* Return t if OBJECT is a process. */) @@ -833,6 +850,14 @@ nil, indicating the current buffer's process. */) process = get_process (process); p = XPROCESS (process); +#ifdef HAVE_GETADDRINFO_A + if (p->dns_requests) + { + gai_cancel (p->dns_requests[0]); + free_dns_request (process); + } +#endif + p->raw_status_new = 0; if (NETCONN1_P (p) || SERIALCONN1_P (p) || PIPECONN1_P (p)) { @@ -4652,10 +4677,6 @@ check_for_dns (Lisp_Object proc) if (! p->dns_requests) return Qnil; - /* This process should not already be connected (or killed). */ - if (!EQ (p->status, Qconnect)) - return Qnil; - ret = gai_error (p->dns_requests[0]); if (ret == EAI_INPROGRESS) return Qt; @@ -4673,10 +4694,9 @@ check_for_dns (Lisp_Object proc) } ip_addresses = Fnreverse (ip_addresses); - freeaddrinfo (p->dns_requests[0]->ar_result); } /* The DNS lookup failed. */ - else + else if (!EQ (p->status, Qconnect)) { deactivate_process (proc); pset_status (p, (list2 @@ -4686,12 +4706,11 @@ check_for_dns (Lisp_Object proc) build_string (" failed"))))); } - xfree ((void *)p->dns_requests[0]->ar_request); - xfree ((void *)p->dns_requests[0]->ar_name); - xfree ((void *)p->dns_requests[0]->ar_service); - xfree (p->dns_requests[0]); - xfree (p->dns_requests); - p->dns_requests = NULL; + free_dns_request (proc); + + /* This process should not already be connected (or killed). */ + if (!EQ (p->status, Qconnect)) + return Qnil; return ip_addresses; } commit e4324bdf565fd934afa7558d4356f040d3a66c6e Author: Alain Schneble Date: Tue Feb 16 13:13:06 2016 +1100 Don't block in set-process-window-size * src/process.c (set-process-window-size): Explicitly return Qnil when called with network processes as set_window_size won't work anyway on socket fds. As a welcome side effect, this makes the blocking wait_for_socket_fds call obsolete. diff --git a/src/process.c b/src/process.c index 7783783..9c09aee 100644 --- a/src/process.c +++ b/src/process.c @@ -1115,14 +1115,12 @@ DEFUN ("set-process-window-size", Fset_process_window_size, { CHECK_PROCESS (process); - if (NETCONN_P (process)) - wait_for_socket_fds (process, "set-process-window-size"); - /* All known platforms store window sizes as 'unsigned short'. */ CHECK_RANGED_INTEGER (height, 0, USHRT_MAX); CHECK_RANGED_INTEGER (width, 0, USHRT_MAX); - if (XPROCESS (process)->infd < 0 + if (NETCONN_P (process) + || XPROCESS (process)->infd < 0 || (set_window_size (XPROCESS (process)->infd, XINT (height), XINT (width)) < 0)) commit 7f3441cc3335b5faf7cb52458256dbbbaaaf9fa7 Author: Lars Ingebrigtsen Date: Tue Feb 16 13:01:05 2016 +1100 Do most of the coding system setup earlier * src/process.c (Fmake_network_process): Set the read/write coding systems here, so that special bindings work. (Fmake_network_process): Complete the coding system setup here. diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el index 8bd35a5..2b552df 100644 --- a/lisp/url/url-gw.el +++ b/lisp/url/url-gw.el @@ -246,7 +246,7 @@ overriding the value of `url-gateway-method'." :type gw-method ;; Use non-blocking socket if we can. :nowait (featurep 'make-network-process - '(:nowait t)))) + '(:nowait t)))) (`socks (socks-open-network-stream name buffer host service)) (`telnet @@ -256,6 +256,7 @@ overriding the value of `url-gateway-method'." (_ (error "Bad setting of url-gateway-method: %s" url-gateway-method)))))) + (message "Coding system: %s" (process-coding-system conn)) conn))) (provide 'url-gw) diff --git a/src/process.c b/src/process.c index f1c066f..7783783 100644 --- a/src/process.c +++ b/src/process.c @@ -3004,8 +3004,6 @@ void set_network_socket_coding_system (Lisp_Object proc) } pset_encode_coding_system (p, val); - setup_process_coding_systems (proc); - pset_decoding_buf (p, empty_unibyte_string); p->decoding_carryover = 0; pset_encoding_buf (p, empty_unibyte_string); @@ -3321,7 +3319,7 @@ void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) if (inch > max_process_desc) max_process_desc = inch; - set_network_socket_coding_system (proc); + setup_process_coding_systems (proc); #ifdef HAVE_GNUTLS /* Continue the asynchronous connection. */ @@ -3897,6 +3895,8 @@ usage: (make-network-process &rest ARGS) */) p->gnutls_boot_parameters = tem; #endif + set_network_socket_coding_system (proc); + unbind_to (count, Qnil); /* :server BOOL */ commit 2d7af7e206c746bc774ae34de88dc2c20ea1b07d Author: Lars Ingebrigtsen Date: Mon Feb 15 20:10:10 2016 +1100 Protect against initial handshake failures * src/process.c (connect_network_socket): Mark the connection as failed if the handshake didn't succeed yet. This should be reworked later. diff --git a/src/process.c b/src/process.c index e890071..f1c066f 100644 --- a/src/process.c +++ b/src/process.c @@ -3332,7 +3332,8 @@ void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) boot = Fgnutls_boot (proc, XCAR (params), XCDR (params)); p->gnutls_boot_parameters = Qnil; - if (NILP (boot) || STRINGP (boot)) + if (NILP (boot) || STRINGP (boot) || + p->gnutls_initstage != GNUTLS_STAGE_READY) { deactivate_process (proc); if (NILP (boot)) commit 9c74f2fea6bfa6bc38358835539944017cf35917 Author: Lars Ingebrigtsen Date: Mon Feb 15 18:24:08 2016 +1100 Call the network security manager after doing TLS negotiation * lisp/net/network-stream.el (network-stream-open-tls): Postpone NSM verification when running async. * src/process.c (Fset_process_filter): This function doesn't need to wait. (connect_network_socket): Set the process status to "run" only after TLS negotiation. (wait_for_socket_fds): Take a name parameter for more debugging. (wait_reading_process_output): Don't change status to "run" unless TLS negotiation has finished. (send_process): Wait for the process here instead of send_process_string. (connect_network_socket): Call the network security manager. diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el index b0d479f..1bba35a 100644 --- a/lisp/net/network-stream.el +++ b/lisp/net/network-stream.el @@ -372,27 +372,29 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (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) diff --git a/src/process.c b/src/process.c index 1dd5274..e890071 100644 --- a/src/process.c +++ b/src/process.c @@ -284,7 +284,7 @@ static Lisp_Object chan_process[FD_SETSIZE]; #ifdef HAVE_GETADDRINFO_A /* Pending DNS requests. */ static Lisp_Object dns_processes; -static void wait_for_socket_fds (Lisp_Object process); +static void wait_for_socket_fds (Lisp_Object process, char *name); #endif /* Alist of elements (NAME . PROCESS). */ @@ -1031,9 +1031,6 @@ The string argument is normally a multibyte string, except: CHECK_PROCESS (process); - if (NETCONN_P (process)) - wait_for_socket_fds (process); - p = XPROCESS (process); /* Don't signal an error if the process's input file descriptor @@ -1119,7 +1116,7 @@ DEFUN ("set-process-window-size", Fset_process_window_size, CHECK_PROCESS (process); if (NETCONN_P (process)) - wait_for_socket_fds (process); + wait_for_socket_fds (process, "set-process-window-size"); /* All known platforms store window sizes as 'unsigned short'. */ CHECK_RANGED_INTEGER (height, 0, USHRT_MAX); @@ -1204,7 +1201,7 @@ list of keywords. */) #ifdef DATAGRAM_SOCKETS if (NETCONN_P (process)) - wait_for_socket_fds (process); + wait_for_socket_fds (process, "process-contact"); if (DATAGRAM_CONN_P (process) && (EQ (key, Qt) || EQ (key, QCremote))) @@ -2436,7 +2433,7 @@ DEFUN ("process-datagram-address", Fprocess_datagram_address, Sprocess_datagram_ CHECK_PROCESS (process); if (NETCONN_P (process)) - wait_for_socket_fds (process); + wait_for_socket_fds (process, "process-datagram-address"); if (!DATAGRAM_CONN_P (process)) return Qnil; @@ -2458,7 +2455,7 @@ Returns nil upon error setting address, ADDRESS otherwise. */) CHECK_PROCESS (process); if (NETCONN_P (process)) - wait_for_socket_fds (process); + wait_for_socket_fds (process, "set-process-datagram-address"); if (!DATAGRAM_CONN_P (process)) return Qnil; @@ -2628,7 +2625,7 @@ OPTION is not a supported option, return nil instead; otherwise return t. */) if (!NETCONN1_P (p)) error ("Process is not a network process"); - wait_for_socket_fds (process); + wait_for_socket_fds (process, "set-network-process-option"); s = p->infd; if (s < 0) @@ -3332,16 +3329,49 @@ void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) { Lisp_Object boot, params = p->gnutls_boot_parameters; - p->gnutls_boot_parameters = Qnil; boot = Fgnutls_boot (proc, XCAR (params), XCDR (params)); - if (NILP (boot) || STRINGP (boot)) { - deactivate_process (proc); - if (NILP (boot)) - pset_status (p, list2 (Qfailed, - build_string ("TLS negotiation failed"))); - else - pset_status (p, list2 (Qfailed, boot)); - } + p->gnutls_boot_parameters = Qnil; + + if (NILP (boot) || STRINGP (boot)) + { + deactivate_process (proc); + if (NILP (boot)) + pset_status (p, list2 (Qfailed, + build_string ("TLS negotiation failed"))); + else + pset_status (p, list2 (Qfailed, boot)); + } + else + { + Lisp_Object result = Qt; + + if (!NILP (Ffboundp (Qnsm_verify_connection))) + result = call3 (Qnsm_verify_connection, + proc, + Fplist_get (contact, QChost), + Fplist_get (contact, QCservice)); + + if (NILP (result)) + { + pset_status (p, list2 (Qfailed, + build_string ("The Network Security Manager stopped the connections"))); + deactivate_process (proc); + } + else + { + /* If we cleared the connection wait mask before we did + the TLS setup, then we have to say that the process + is finally "open" here. */ + if (! FD_ISSET (p->outfd, &connect_wait_mask)) + { + pset_status (p, Qrun); + /* Execute the sentinel here. If we had relied on + status_notify to do it later, it will read input + from the process before calling the sentinel. */ + exec_sentinel (proc, build_string ("open\n")); + } + } + } } #endif @@ -4670,27 +4700,36 @@ check_for_dns (Lisp_Object proc) #endif /* HAVE_GETADDRINFO_A */ static void -wait_for_socket_fds (Lisp_Object process) +wait_for_socket_fds (Lisp_Object process, char *name) { while (XPROCESS (process)->infd < 0 && EQ (XPROCESS (process)->status, Qconnect)) - wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0); + { + printf("Waiting for socket from %s...\n", name); + wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0); + } } static void wait_while_connecting (Lisp_Object process) { while (EQ (XPROCESS (process)->status, Qconnect)) - wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0); + { + printf("Waiting for connection...\n"); + wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0); + } } static void wait_for_tls_negotiation (Lisp_Object process) { #ifdef HAVE_GNUTLS - while (EQ (XPROCESS (process)->status, Qrun) && + while (EQ (XPROCESS (process)->status, Qconnect) && !NILP (XPROCESS (process)->gnutls_boot_parameters)) - wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0); + { + printf("Waiting for TLS...\n"); + wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0); + } #endif } @@ -5486,11 +5525,15 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, } else { - pset_status (p, Qrun); - /* Execute the sentinel here. If we had relied on - status_notify to do it later, it will read input - from the process before calling the sentinel. */ - exec_sentinel (proc, build_string ("open\n")); + if (NILP (p->gnutls_boot_parameters)) + { + pset_status (p, Qrun); + /* Execute the sentinel here. If we had relied on + status_notify to do it later, it will read input + from the process before calling the sentinel. */ + exec_sentinel (proc, build_string ("open\n")); + } + if (0 <= p->infd && !EQ (p->filter, Qt) && !EQ (p->command, Qt)) { @@ -5947,6 +5990,11 @@ send_process (Lisp_Object proc, const char *buf, ptrdiff_t len, ssize_t rv; struct coding_system *coding; + if (NETCONN_P (proc)) { + wait_while_connecting (proc); + wait_for_tls_negotiation (proc); + } + if (p->raw_status_new) update_status (p); if (! EQ (p->status, Qrun)) @@ -6201,11 +6249,6 @@ Output from processes can arrive in between bunches. */) CHECK_STRING (string); proc = get_process (process); - if (NETCONN_P (proc)) { - wait_while_connecting (proc); - wait_for_tls_negotiation (proc); - } - send_process (proc, SSDATA (string), SBYTES (string), string); return Qnil; @@ -7081,7 +7124,7 @@ encode subprocess input. */) CHECK_PROCESS (process); if (NETCONN_P (process)) - wait_for_socket_fds (process); + wait_for_socket_fds (process, "set-process-coding-system"); p = XPROCESS (process); @@ -7123,7 +7166,7 @@ suppressed. */) CHECK_PROCESS (process); if (NETCONN_P (process)) - wait_for_socket_fds (process); + wait_for_socket_fds (process, "set-process-filter-multibyte"); p = XPROCESS (process); if (NILP (flag)) @@ -7817,6 +7860,7 @@ syms_of_process (void) DEFSYM (QCnowait, ":nowait"); DEFSYM (QCsentinel, ":sentinel"); DEFSYM (QCtls_parameters, ":tls-parameters"); + DEFSYM (Qnsm_verify_connection, "nsm-verify-connection"); DEFSYM (QClog, ":log"); DEFSYM (QCnoquery, ":noquery"); DEFSYM (QCstop, ":stop"); commit 40155283c380a795c1a0036a31e1b41ed1df0f38 Author: Lars Ingebrigtsen Date: Mon Feb 15 16:05:14 2016 +1100 Remove some #ifdefs and update documentation * doc/lispref/processes.texi (Network Processes): Remove mention of `dns'. * lisp/net/network-stream.el (open-network-stream): Remove mention of `dns'. * src/process.c (Fset_process_filter) (Fset_process_window_size, Fprocess_contact) (Fprocess_datagram_address, Fset_process_datagram_address) (Fset_network_process_option, Fprocess_send_region) (Fprocess_send_string, Fset_process_coding_system) (Fset_process_filter_multibyte): Remove the #ifdef HAVE_GETADDRINFO_A checks. (Fprocess_send_string): Wait for TLS negotiation. (wait_for_tls_negotiation): New function. (send_process): Remove the TLS boot check. * src/process.c (Fmake_network_process): Ditto. diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index a1c8755..60b2d90 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -2418,12 +2418,6 @@ second argument matching @code{"open"} (if successful) or @code{make-network-process} does not return until the connection has succeeded or failed. -If @var{nowait} is @code{dns}, also do the @acronym{DNS} lookup -asynchronously, if supported. In that case, the process is returned -before a connection has been made, and the client should not try -communicating with the process until it has changed status to -@code{"connected"}. - @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 diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el index 6767446..b0d479f 100644 --- a/lisp/net/network-stream.el +++ b/lisp/net/network-stream.el @@ -137,11 +137,7 @@ non-nil, is used warn the user if the connection isn't encrypted. a greeting from the server. :nowait, if non-nil, says the connection should be made -asynchronously, if possible. If it is `dns', also do the DNS -lookup asynchronously, if supported. In that case, the process -is returned before a connection has been made, and the client -should not try communicating with the process until it has -changed status to \"connected\". +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 diff --git a/src/process.c b/src/process.c index 5acf315..1dd5274 100644 --- a/src/process.c +++ b/src/process.c @@ -1031,10 +1031,8 @@ The string argument is normally a multibyte string, except: CHECK_PROCESS (process); -#ifdef HAVE_GETADDRINFO_A if (NETCONN_P (process)) wait_for_socket_fds (process); -#endif p = XPROCESS (process); @@ -1120,10 +1118,8 @@ DEFUN ("set-process-window-size", Fset_process_window_size, { CHECK_PROCESS (process); -#ifdef HAVE_GETADDRINFO_A if (NETCONN_P (process)) wait_for_socket_fds (process); -#endif /* All known platforms store window sizes as 'unsigned short'. */ CHECK_RANGED_INTEGER (height, 0, USHRT_MAX); @@ -1207,10 +1203,8 @@ list of keywords. */) #ifdef DATAGRAM_SOCKETS -#ifdef HAVE_GETADDRINFO_A if (NETCONN_P (process)) wait_for_socket_fds (process); -#endif if (DATAGRAM_CONN_P (process) && (EQ (key, Qt) || EQ (key, QCremote))) @@ -2441,10 +2435,8 @@ DEFUN ("process-datagram-address", Fprocess_datagram_address, Sprocess_datagram_ CHECK_PROCESS (process); -#ifdef HAVE_GETADDRINFO_A if (NETCONN_P (process)) wait_for_socket_fds (process); -#endif if (!DATAGRAM_CONN_P (process)) return Qnil; @@ -2465,10 +2457,8 @@ Returns nil upon error setting address, ADDRESS otherwise. */) CHECK_PROCESS (process); -#ifdef HAVE_GETADDRINFO_A if (NETCONN_P (process)) wait_for_socket_fds (process); -#endif if (!DATAGRAM_CONN_P (process)) return Qnil; @@ -2638,9 +2628,7 @@ OPTION is not a supported option, return nil instead; otherwise return t. */) if (!NETCONN1_P (p)) error ("Process is not a network process"); -#ifdef HAVE_GETADDRINFO_A wait_for_socket_fds (process); -#endif s = p->infd; if (s < 0) @@ -3453,16 +3441,12 @@ system used for both reading and writing for this process. If CODING is a cons (DECODING . ENCODING), DECODING is used for reading, and ENCODING is used for writing. -:nowait NOWAIT -- If NOWAIT is non-nil for a stream type client +:nowait BOOL -- If NOWAIT is non-nil for a stream type client process, return without waiting for the connection to complete; instead, the sentinel function will be called with second arg matching "open" (if successful) or "failed" when the connect completes. Default is to use a blocking connect (i.e. wait) for stream type -connections. If NOWAIT is `dns', also do the DNS lookup -asynchronously, if supported. In that case, the process is returned -before a connection has been made, and the client should not try -communicating with the process until it has changed status to -"connected". +connections. :noquery BOOL -- Query the user unless BOOL is non-nil, and process is running when Emacs is exited. @@ -3725,7 +3709,7 @@ usage: (make-network-process &rest ARGS) */) #endif #ifdef HAVE_GETADDRINFO_A - if (EQ (Fplist_get (contact, QCnowait), Qt) && + if (!NILP (Fplist_get (contact, QCnowait)) && !NILP (host)) { int ret; @@ -4683,24 +4667,32 @@ check_for_dns (Lisp_Object proc) return ip_addresses; } +#endif /* HAVE_GETADDRINFO_A */ + static void -wait_for_socket_fds(Lisp_Object process) +wait_for_socket_fds (Lisp_Object process) { - while (XPROCESS(process)->dns_requests) - { - wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0); - } + while (XPROCESS (process)->infd < 0 && + EQ (XPROCESS (process)->status, Qconnect)) + wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0); } static void -wait_while_connecting(Lisp_Object process) +wait_while_connecting (Lisp_Object process) { - while (EQ (Qconnect, XPROCESS(process)->status)) - { - wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0); - } + while (EQ (XPROCESS (process)->status, Qconnect)) + wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0); +} + +static void +wait_for_tls_negotiation (Lisp_Object process) +{ +#ifdef HAVE_GNUTLS + while (EQ (XPROCESS (process)->status, Qrun) && + !NILP (XPROCESS (process)->gnutls_boot_parameters)) + wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0); +#endif } -#endif /* HAVE_GETADDRINFO_A */ /* This variable is different from waiting_for_input in keyboard.c. It is used to communicate to a lisp process-filter/sentinel (via the @@ -5962,13 +5954,6 @@ send_process (Lisp_Object proc, const char *buf, ptrdiff_t len, if (p->outfd < 0) error ("Output file descriptor of %s is closed", SDATA (p->name)); -#ifdef HAVE_GNUTLS - /* The TLS connection hasn't been set up yet, so we can't write - anything on the socket. */ - if (!NILP (p->gnutls_boot_parameters)) - return; -#endif - coding = proc_encode_coding_system[p->outfd]; Vlast_coding_system_used = CODING_ID_NAME (coding->id); @@ -6193,10 +6178,8 @@ Output from processes can arrive in between bunches. */) if (XINT (start) < GPT && XINT (end) > GPT) move_gap_both (XINT (start), start_byte); -#ifdef HAVE_GETADDRINFO_A if (NETCONN_P (proc)) wait_while_connecting (proc); -#endif send_process (proc, (char *) BYTE_POS_ADDR (start_byte), end_byte - start_byte, Fcurrent_buffer ()); @@ -6218,10 +6201,10 @@ Output from processes can arrive in between bunches. */) CHECK_STRING (string); proc = get_process (process); -#ifdef HAVE_GETADDRINFO_A - if (NETCONN_P (proc)) + if (NETCONN_P (proc)) { wait_while_connecting (proc); -#endif + wait_for_tls_negotiation (proc); + } send_process (proc, SSDATA (string), SBYTES (string), string); @@ -6639,10 +6622,8 @@ process has been transmitted to the serial port. */) proc = get_process (process); -#ifdef HAVE_GETADDRINFO_A if (NETCONN_P (proc)) wait_while_connecting (proc); -#endif if (DATAGRAM_CONN_P (proc)) return process; @@ -7099,10 +7080,8 @@ encode subprocess input. */) CHECK_PROCESS (process); -#ifdef HAVE_GETADDRINFO_A if (NETCONN_P (process)) wait_for_socket_fds (process); -#endif p = XPROCESS (process); @@ -7143,10 +7122,8 @@ suppressed. */) CHECK_PROCESS (process); -#ifdef HAVE_GETADDRINFO_A if (NETCONN_P (process)) wait_for_socket_fds (process); -#endif p = XPROCESS (process); if (NILP (flag)) commit 204847702b925b5e2377a0a12278308657674af7 Author: Lars Ingebrigtsen Date: Mon Feb 15 15:59:49 2016 +1100 Use :nowait t in url-gw * lisp/url/url-gw.el (url-open-stream): Just use :nowait t, since we're not differentiating. diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el index 4d1dce6..8bd35a5 100644 --- a/lisp/url/url-gw.el +++ b/lisp/url/url-gw.el @@ -245,10 +245,9 @@ overriding the value of `url-gateway-method'." name buffer host service :type gw-method ;; Use non-blocking socket if we can. - :nowait (and (featurep 'make-network-process - '(:nowait t)) - 'dns))) - (`socks + :nowait (featurep 'make-network-process + '(:nowait t)))) + (`socks (socks-open-network-stream name buffer host service)) (`telnet (url-open-telnet name buffer host service)) commit c740d190e857bf63d04ec0d00eeeed23bbd66ace Author: Alain Schneble Date: Mon Feb 15 15:44:29 2016 +1100 Add blockers to process functions * src/process.c (set-process-filter, set-process-window-size, process-contact, process-datagram-address, set-process-datagram-address, set-network-process-option): Make functions wait (block) on network process until pending DNS requests have been processed and associated socket initialized. * src/process.c (process-send-region, process-send-string, process-send-eof): Make functions wait (block) while network process is in connect state. diff --git a/src/process.c b/src/process.c index 497b069..5acf315 100644 --- a/src/process.c +++ b/src/process.c @@ -284,6 +284,7 @@ static Lisp_Object chan_process[FD_SETSIZE]; #ifdef HAVE_GETADDRINFO_A /* Pending DNS requests. */ static Lisp_Object dns_processes; +static void wait_for_socket_fds (Lisp_Object process); #endif /* Alist of elements (NAME . PROCESS). */ @@ -1029,6 +1030,12 @@ The string argument is normally a multibyte string, except: struct Lisp_Process *p; CHECK_PROCESS (process); + +#ifdef HAVE_GETADDRINFO_A + if (NETCONN_P (process)) + wait_for_socket_fds (process); +#endif + p = XPROCESS (process); /* Don't signal an error if the process's input file descriptor @@ -1113,6 +1120,11 @@ DEFUN ("set-process-window-size", Fset_process_window_size, { CHECK_PROCESS (process); +#ifdef HAVE_GETADDRINFO_A + if (NETCONN_P (process)) + wait_for_socket_fds (process); +#endif + /* All known platforms store window sizes as 'unsigned short'. */ CHECK_RANGED_INTEGER (height, 0, USHRT_MAX); CHECK_RANGED_INTEGER (width, 0, USHRT_MAX); @@ -1194,6 +1206,12 @@ list of keywords. */) contact = XPROCESS (process)->childp; #ifdef DATAGRAM_SOCKETS + +#ifdef HAVE_GETADDRINFO_A + if (NETCONN_P (process)) + wait_for_socket_fds (process); +#endif + if (DATAGRAM_CONN_P (process) && (EQ (key, Qt) || EQ (key, QCremote))) contact = Fplist_put (contact, QCremote, @@ -2423,6 +2441,11 @@ DEFUN ("process-datagram-address", Fprocess_datagram_address, Sprocess_datagram_ CHECK_PROCESS (process); +#ifdef HAVE_GETADDRINFO_A + if (NETCONN_P (process)) + wait_for_socket_fds (process); +#endif + if (!DATAGRAM_CONN_P (process)) return Qnil; @@ -2442,6 +2465,11 @@ Returns nil upon error setting address, ADDRESS otherwise. */) CHECK_PROCESS (process); +#ifdef HAVE_GETADDRINFO_A + if (NETCONN_P (process)) + wait_for_socket_fds (process); +#endif + if (!DATAGRAM_CONN_P (process)) return Qnil; @@ -2610,6 +2638,10 @@ OPTION is not a supported option, return nil instead; otherwise return t. */) if (!NETCONN1_P (p)) error ("Process is not a network process"); +#ifdef HAVE_GETADDRINFO_A + wait_for_socket_fds (process); +#endif + s = p->infd; if (s < 0) error ("Process is not running"); @@ -3693,7 +3725,7 @@ usage: (make-network-process &rest ARGS) */) #endif #ifdef HAVE_GETADDRINFO_A - if (EQ (Fplist_get (contact, QCnowait), Qdns) && + if (EQ (Fplist_get (contact, QCnowait), Qt) && !NILP (host)) { int ret; @@ -4650,6 +4682,24 @@ check_for_dns (Lisp_Object proc) return ip_addresses; } + +static void +wait_for_socket_fds(Lisp_Object process) +{ + while (XPROCESS(process)->dns_requests) + { + wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0); + } +} + +static void +wait_while_connecting(Lisp_Object process) +{ + while (EQ (Qconnect, XPROCESS(process)->status)) + { + wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0); + } +} #endif /* HAVE_GETADDRINFO_A */ /* This variable is different from waiting_for_input in keyboard.c. @@ -6143,6 +6193,11 @@ Output from processes can arrive in between bunches. */) if (XINT (start) < GPT && XINT (end) > GPT) move_gap_both (XINT (start), start_byte); +#ifdef HAVE_GETADDRINFO_A + if (NETCONN_P (proc)) + wait_while_connecting (proc); +#endif + send_process (proc, (char *) BYTE_POS_ADDR (start_byte), end_byte - start_byte, Fcurrent_buffer ()); @@ -6162,6 +6217,12 @@ Output from processes can arrive in between bunches. */) Lisp_Object proc; CHECK_STRING (string); proc = get_process (process); + +#ifdef HAVE_GETADDRINFO_A + if (NETCONN_P (proc)) + wait_while_connecting (proc); +#endif + send_process (proc, SSDATA (string), SBYTES (string), string); return Qnil; @@ -6576,10 +6637,17 @@ process has been transmitted to the serial port. */) struct coding_system *coding = NULL; int outfd; - if (DATAGRAM_CONN_P (process)) + proc = get_process (process); + +#ifdef HAVE_GETADDRINFO_A + if (NETCONN_P (proc)) + wait_while_connecting (proc); +#endif + + if (DATAGRAM_CONN_P (proc)) return process; - proc = get_process (process); + outfd = XPROCESS (proc)->outfd; if (outfd >= 0) coding = proc_encode_coding_system[outfd]; @@ -7030,7 +7098,14 @@ encode subprocess input. */) register struct Lisp_Process *p; CHECK_PROCESS (process); + +#ifdef HAVE_GETADDRINFO_A + if (NETCONN_P (process)) + wait_for_socket_fds (process); +#endif + p = XPROCESS (process); + if (p->infd < 0) error ("Input file descriptor of %s closed", SDATA (p->name)); if (p->outfd < 0) @@ -7067,6 +7142,12 @@ suppressed. */) register struct Lisp_Process *p; CHECK_PROCESS (process); + +#ifdef HAVE_GETADDRINFO_A + if (NETCONN_P (process)) + wait_for_socket_fds (process); +#endif + p = XPROCESS (process); if (NILP (flag)) pset_decode_coding_system @@ -7757,7 +7838,6 @@ syms_of_process (void) DEFSYM (QCcoding, ":coding"); DEFSYM (QCserver, ":server"); DEFSYM (QCnowait, ":nowait"); - DEFSYM (Qdns, "dns"); DEFSYM (QCsentinel, ":sentinel"); DEFSYM (QCtls_parameters, ":tls-parameters"); DEFSYM (QClog, ":log"); @@ -7921,9 +8001,6 @@ The variable takes effect when `start-process' is called. */); #ifdef NON_BLOCKING_CONNECT ADD_SUBFEATURE (QCnowait, Qt); -#ifdef HAVE_GETADDRINFO_A - ADD_SUBFEATURE (QCnowait, Qdns); -#endif #endif #ifdef DATAGRAM_SOCKETS ADD_SUBFEATURE (QCtype, Qdatagram); commit 51d728c8345416ab50a378a789dde645a7247499 Author: David Edmondson Date: Sun Feb 7 12:54:08 2016 +1100 src/process.c Correctly convert AF_INET6 addresses * src/process.c (conv_lisp_to_sockaddr): AF_INET6 addresses are converted to a list of 16 bit quantities by conv_sockaddr_to_lisp(). conv_lisp_to_sockaddr() should follow the same scheme rather than expecting a (longer) list of 8 bit quantities. diff --git a/src/process.c b/src/process.c index 9653eba..497b069 100644 --- a/src/process.c +++ b/src/process.c @@ -2372,7 +2372,7 @@ conv_lisp_to_sockaddr (int family, Lisp_Object address, struct sockaddr *sa, int { struct sockaddr_in6 *sin6 = (struct sockaddr_in6 *) sa; uint16_t *ip6 = (uint16_t *)&sin6->sin6_addr; - len = sizeof (sin6->sin6_addr) + 1; + len = sizeof (sin6->sin6_addr) / 2 + 1; hostport = XINT (p->contents[--len]); sin6->sin6_port = htons (hostport); for (i = 0; i < len; i++) commit 71f22453a5fabbf7d21c8b34bfc2d107eed1db68 Author: Lars Ingebrigtsen Date: Tue Feb 9 10:24:34 2016 +1100 Add an IPv6 test * test/lisp/net/network-stream-tests.el (connect-to-tls-ipv6-nowait): Add an ipv6 test, too. diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el index 9d9d561..a50c7f0 100644 --- a/test/lisp/net/network-stream-tests.el +++ b/test/lisp/net/network-stream-tests.el @@ -162,7 +162,7 @@ "--x509certfile" "lisp/net/cert.pem" "--port" "44330")) -(ert-deftest connect-to-tls () +(ert-deftest connect-to-tls-ipv4-wait () (skip-unless (executable-find "gnutls-serv")) (skip-unless (gnutls-available-p)) (let ((server (make-tls-server)) @@ -194,4 +194,38 @@ (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)) + (let ((server (make-tls-server)) + (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*") + :family 'ipv6 + :nowait t + :host "::1" + :service 44330)))) + (< (setq times (1+ times)) 10)) + (sit-for 0.1)) + (should proc) + (gnutls-negotiate :process proc + :type 'gnutls-x509pki + :hostname "localhost") + (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"))))) + ;;; network-stream-tests.el ends here commit a2d6d79c952e1cbb3387fb33ead9b3ddee880a21 Author: Lars Ingebrigtsen Date: Tue Feb 9 10:16:14 2016 +1100 Use gnutls-serv instead of openssh * test/lisp/net/network-stream-tests.el (make-tls-server): Use gnutls-serv instead of openssh. diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el index ad7c1fc..9d9d561 100644 --- a/test/lisp/net/network-stream-tests.el +++ b/test/lisp/net/network-stream-tests.el @@ -156,23 +156,23 @@ (delete-process server))) (defun make-tls-server () - (start-process "openssl" (generate-new-buffer "*tls*") "openssl" - "s_server" "-key" "lisp/net/key.pem" - "-cert" "lisp/net/cert.pem" - "-accept" "44330" - "-www")) + (start-process "gnutls" (generate-new-buffer "*tls*") + "gnutls-serv" "--http" + "--x509keyfile" "lisp/net/key.pem" + "--x509certfile" "lisp/net/cert.pem" + "--port" "44330")) (ert-deftest connect-to-tls () - (skip-unless (executable-find "openssl")) + (skip-unless (executable-find "gnutls-serv")) (skip-unless (gnutls-available-p)) (let ((server (make-tls-server)) (times 0) proc status) (sleep-for 1) (with-current-buffer (process-buffer server) - (message "openssl: %s" (buffer-string))) + (message "gnutls-serv: %s" (buffer-string))) - ;; It takes a while for openssl to start. + ;; It takes a while for gnutls-serv to start. (while (and (null (ignore-errors (setq proc (make-network-process :name "bar" commit 04913ccfa9fec9421f36b1cb46c9a4596e0ec1f3 Author: Lars Ingebrigtsen Date: Mon Feb 8 18:28:00 2016 +1100 Skip TLS tests if we don't have openssl * test/lisp/net/network-stream-tests.el (connect-to-tls): Skip TLS tests if we don't have openssl and GnuTLS. diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el index 478b824..ad7c1fc 100644 --- a/test/lisp/net/network-stream-tests.el +++ b/test/lisp/net/network-stream-tests.el @@ -163,6 +163,8 @@ "-www")) (ert-deftest connect-to-tls () + (skip-unless (executable-find "openssl")) + (skip-unless (gnutls-available-p)) (let ((server (make-tls-server)) (times 0) proc status) commit ea87d91d57790b544d38cbf005e3c726358a7fdd Author: Lars Ingebrigtsen Date: Mon Feb 8 15:28:50 2016 +1100 Add a TLS connection test * test/lisp/net/network-stream-tests.el (connect-to-tls): Add a TLS connection test. diff --git a/test/lisp/net/cert.pem b/test/lisp/net/cert.pem new file mode 100644 index 0000000..4df4e92 --- /dev/null +++ b/test/lisp/net/cert.pem @@ -0,0 +1,25 @@ +-----BEGIN CERTIFICATE----- +MIIELTCCAxWgAwIBAgIJAI6LqlFyaPRkMA0GCSqGSIb3DQEBCwUAMIGsMQswCQYD +VQQGEwJBVTEYMBYGA1UECAwPTmV3IFNvdXRoIFdhbGVzMQ8wDQYDVQQHDAZTeWRu +ZXkxITAfBgNVBAoMGEVtYWNzIFRlc3QgU2VydmljZXNzIExMQzESMBAGA1UECwwJ +QXV0b21hdGVkMRcwFQYDVQQDDA50ZXN0LmVtYWNzLnpvdDEiMCAGCSqGSIb3DQEJ +ARYTZW1hY3MtZGV2ZWxAZnNmLm9yZzAeFw0xNjAyMDgwNDA0MzJaFw0xNjAzMDkw +NDA0MzJaMIGsMQswCQYDVQQGEwJBVTEYMBYGA1UECAwPTmV3IFNvdXRoIFdhbGVz +MQ8wDQYDVQQHDAZTeWRuZXkxITAfBgNVBAoMGEVtYWNzIFRlc3QgU2VydmljZXNz +IExMQzESMBAGA1UECwwJQXV0b21hdGVkMRcwFQYDVQQDDA50ZXN0LmVtYWNzLnpv +dDEiMCAGCSqGSIb3DQEJARYTZW1hY3MtZGV2ZWxAZnNmLm9yZzCCASIwDQYJKoZI +hvcNAQEBBQADggEPADCCAQoCggEBAM52lP7k1rBpctBX1irRVgDerxqlFSTkvg8L +WmRCfwm3XY8EZWqM/8Eex5soH7myRlWfUH/cKxbqScZqXotj0hlPxdRkM6gWgHS9 +Mml7wnz2LZGvD5PfMfs+yBHKAMrqortFXCKksHsYIJ66l9gJMm1G5XjWha6CaEr/ +k2bE5Ovw0fB2B4vH0OqhJzGyenJOspXZz1ttn3h3UC5fbDXS8fUM9k/FbgJKypWr +zB3P12GcMR939FsR5sqa8nNoCMw+WBzs4XuM5Ad+s/UtEaZvmtwvLwmdB7cgCEyM +x5gaM969SlpOmuy7dDTCCK3lBl6B5dgFKvVcChYwSW+xJz5tfL0CAwEAAaNQME4w +HQYDVR0OBBYEFG3YhH7ZzEdOGstkT67uUh1RylNjMB8GA1UdIwQYMBaAFG3YhH7Z +zEdOGstkT67uUh1RylNjMAwGA1UdEwQFMAMBAf8wDQYJKoZIhvcNAQELBQADggEB +ADnJL2tBMnPepywA57yDfJz54FvrqRd+UAjSiB7/QySDpHnTM3b3sXWfwAkXPTjM +c+jRW2kfdnL6OQW2tpcpPZANGnwK8MJrtGcbHhtPXjgDRhVZp64hsB7ayS+l0Dm7 +2ZBbi2SF8FgZVcQy0WD01ir2raSODo124dMrq+3aHP77YLbiNEKj+wFoDbndQ1FQ +gtIJBE80FADoqc7LnBrpA20aVlfqhKZqe+leYDSZ+CE1iwlPdvD+RTUxVDs5EfpB +qVOHDlzEfVmcMnddKTV8pNYuo93AG4s0KdrGG9RwSvtLaOoHd2i6RmIs+Yiumbau +mXodMxxAEW/cM7Ita/2QVmk= +-----END CERTIFICATE----- diff --git a/test/lisp/net/key.pem b/test/lisp/net/key.pem new file mode 100644 index 0000000..5db58f5 --- /dev/null +++ b/test/lisp/net/key.pem @@ -0,0 +1,28 @@ +-----BEGIN PRIVATE KEY----- +MIIEvgIBADANBgkqhkiG9w0BAQEFAASCBKgwggSkAgEAAoIBAQDOdpT+5NawaXLQ +V9Yq0VYA3q8apRUk5L4PC1pkQn8Jt12PBGVqjP/BHsebKB+5skZVn1B/3CsW6knG +al6LY9IZT8XUZDOoFoB0vTJpe8J89i2Rrw+T3zH7PsgRygDK6qK7RVwipLB7GCCe +upfYCTJtRuV41oWugmhK/5NmxOTr8NHwdgeLx9DqoScxsnpyTrKV2c9bbZ94d1Au +X2w10vH1DPZPxW4CSsqVq8wdz9dhnDEfd/RbEebKmvJzaAjMPlgc7OF7jOQHfrP1 +LRGmb5rcLy8JnQe3IAhMjMeYGjPevUpaTprsu3Q0wgit5QZegeXYBSr1XAoWMElv +sSc+bXy9AgMBAAECggEAaqHkIiGeoE5V9jTncAXeHWTlmyVX3k4luy9p6A5P/nyt +3YevuXBJRzzWatQ2Tno8yUwXD3Ju7s7ie4/EdMmBYYFJ84AtDctRXPm6Z7B7qn6a +2ntH2F+WOOUb/9QMxMCae44/H8VfQLQdZN2KPxHA8Z+ENPzW3mKL6vBE+PcIJLK2 +kTXQdCEIuUb1v4kxKYfjyyHAQ9yHvocUvZdodGHrpmWOr/2QCrqCjwiKnXyvdJMi +JQ4a3dU+JG5Zwr2hScyeLgS4p+M3A2NY+oIACn2rCcsIKC6uvBK3wAbhssaY8z9c +5kap862oMBNmPCxPuQTIIO7ptla0EWHktpFxnu7GIQKBgQDvKyXt82zGHiOZ9acx +4fV7t3NF2MNd9fOn59NYWYRSs2gaEjit6BnsCgiKZOJJ2YFsggBiQMiWuEzwqIdW +bOH8W5AubTxnE2OjeIpH5r8AXI6I/pKdOedM86oeElbL0p53OZqSqBK6vA5SnE76 +fZwC505h/mqH2E6AdKpcyL7sJwKBgQDc/jc4MkVnqF7xcYoJrYEbnkhwqRxIM+0Y +HY2qXszWQPgjae3NK1rw/PEOATzWrHLvRS/utQ8yeLUAZIGsFY8+c1kjvkvl4ZK2 +OnsEOVLmEwjDqqnq3JFYCVSkXfLBGRD3wGldzkCQljOiGuJ/Co1rGHk7CfBmxX2p +kxdts5OKewKBgQDTRsSc7Zs7cMh2a0GlmTyoa6iTHSeIy4rQ2sQimgGApSfjUBFt +30l28G4XA4O7RT9FwZnhMeWA75JYTigwOsNvkNtPiAQB8mjksclGNxqnkRwA/RI7 +fjlMCzxOkFjIeWivXd2kjIDvIM1uQNKsCWZWUks12e/1zSmb5HPSvyuZpQKBgQDQ +qVgKP604ysmav9HOgXy+Tx2nAoYpxp2/f2gbzZcrVfz1szdN2fnsQWh6CMEhEYMU +WQeBJIRM65w72qp1iYXPOaqZDT0suWiFl4I/4sBbbO2BkssNb2Xs8iJxcCOeH8Td +qVfTssNTwf7OuQPTYGtXC6ysCh5ra13Tl4cvlbdhsQKBgFHXP+919wSncLS+2ySD +waBzG6GyVOgV+FE3DrM3Xp4S6fldWYAndKHQ1HjJVDY8SkC2Tk1D7QSQnmS+ZzYs +YqzcnkPCTHLb6wCErs4ZiW0gn9xJnfxyv6wPujsayL4TMsmsqkj/IAB61UjwaA/a +Z+rUw/WkcNPD59AD1J0eeSZu +-----END PRIVATE KEY----- diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el index f52a69e..478b824 100644 --- a/test/lisp/net/network-stream-tests.el +++ b/test/lisp/net/network-stream-tests.el @@ -22,6 +22,8 @@ ;;; Code: +(require 'gnutls) + (ert-deftest make-local-unix-server () (let* ((file (make-temp-name "/tmp/server-test")) (server @@ -101,7 +103,7 @@ :buffer (generate-new-buffer "*foo*") :host (system-name) :service port))) - (with-current-buffer "*foo*" + (with-current-buffer (process-buffer proc) (process-send-string proc "echo foo") (sleep-for 0.1) (should (equal (buffer-string) "foo\n"))) @@ -114,7 +116,7 @@ :buffer (generate-new-buffer "*foo*") :host "localhost" :service port))) - (with-current-buffer "*foo*" + (with-current-buffer (process-buffer proc) (process-send-string proc "echo foo") (sleep-for 0.1) (should (equal (buffer-string) "foo\n"))) @@ -127,7 +129,7 @@ :buffer (generate-new-buffer "*foo*") :host "127.0.0.1" :service port))) - (with-current-buffer "*foo*" + (with-current-buffer (process-buffer proc) (process-send-string proc "echo foo") (sleep-for 0.1) (should (equal (buffer-string) "foo\n"))) @@ -147,10 +149,47 @@ t))) (while (eq (process-status proc) 'connect) (sit-for 0.1)) - (with-current-buffer "*foo*" + (with-current-buffer (process-buffer proc) (process-send-string proc "echo foo") (sleep-for 0.1) (should (equal (buffer-string) "foo\n"))) (delete-process server))) +(defun make-tls-server () + (start-process "openssl" (generate-new-buffer "*tls*") "openssl" + "s_server" "-key" "lisp/net/key.pem" + "-cert" "lisp/net/cert.pem" + "-accept" "44330" + "-www")) + +(ert-deftest connect-to-tls () + (let ((server (make-tls-server)) + (times 0) + proc status) + (sleep-for 1) + (with-current-buffer (process-buffer server) + (message "openssl: %s" (buffer-string))) + + ;; It takes a while for openssl to start. + (while (and (null (ignore-errors + (setq proc (make-network-process + :name "bar" + :buffer (generate-new-buffer "*foo*") + :host "localhost" + :service 44330)))) + (< (setq times (1+ times)) 10)) + (sit-for 0.1)) + (should proc) + (gnutls-negotiate :process proc + :type 'gnutls-x509pki + :hostname "localhost") + (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"))))) + ;;; network-stream-tests.el ends here commit d7e22381769efa0472bb6bf49e7d06387c6e4fc7 Author: Lars Ingebrigtsen Date: Mon Feb 8 14:35:07 2016 +1100 Add more network tests * test/lisp/net/network-stream-tests.el (echo-server-nowait): New test. diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el index 3e0821a..f52a69e 100644 --- a/test/lisp/net/network-stream-tests.el +++ b/test/lisp/net/network-stream-tests.el @@ -75,7 +75,7 @@ :filter 'server-process-filter :host host)) -(defun server-sentinel (proc msg) +(defun server-sentinel (_proc _msg) ) (defun server-process-filter (proc string) @@ -95,7 +95,7 @@ )))) (ert-deftest echo-server-with-dns () - (let* ((server (make-server "mouse")) + (let* ((server (make-server (system-name))) (port (aref (process-contact server :local) 4)) (proc (make-network-process :name "foo" :buffer (generate-new-buffer "*foo*") @@ -104,7 +104,8 @@ (with-current-buffer "*foo*" (process-send-string proc "echo foo") (sleep-for 0.1) - (should (equal (buffer-string) "foo\n"))))) + (should (equal (buffer-string) "foo\n"))) + (delete-process server))) (ert-deftest echo-server-with-localhost () (let* ((server (make-server 'local)) @@ -116,7 +117,8 @@ (with-current-buffer "*foo*" (process-send-string proc "echo foo") (sleep-for 0.1) - (should (equal (buffer-string) "foo\n"))))) + (should (equal (buffer-string) "foo\n"))) + (delete-process server))) (ert-deftest echo-server-with-ip () (let* ((server (make-server 'local)) @@ -128,6 +130,27 @@ (with-current-buffer "*foo*" (process-send-string proc "echo foo") (sleep-for 0.1) - (should (equal (buffer-string) "foo\n"))))) + (should (equal (buffer-string) "foo\n"))) + (delete-process server))) + +(ert-deftest echo-server-nowait () + (let* ((server (make-server 'local)) + (port (aref (process-contact server :local) 4)) + (proc (make-network-process :name "foo" + :buffer (generate-new-buffer "*foo*") + :host "localhost" + :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 "*foo*" + (process-send-string proc "echo foo") + (sleep-for 0.1) + (should (equal (buffer-string) "foo\n"))) + (delete-process server))) ;;; network-stream-tests.el ends here commit 92acfb90c68981544e6074d5779d7859c4fea487 Author: Lars Ingebrigtsen Date: Mon Feb 8 14:24:25 2016 +1100 Add network tests * test/lisp/net/network-stream-tests.el: New suite of network tests. diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el new file mode 100644 index 0000000..3e0821a --- /dev/null +++ b/test/lisp/net/network-stream-tests.el @@ -0,0 +1,133 @@ +;;; network-stream-tests.el --- tests for network processes -*- lexical-binding: t; -*- + +;; Copyright (C) 2016 Free Software Foundation, Inc. + +;; Author: Lars Ingebrigtsen + +;; 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. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + + +;;; Code: + +(ert-deftest make-local-unix-server () + (let* ((file (make-temp-name "/tmp/server-test")) + (server + (make-network-process + :name "server" + :server t + :buffer (get-buffer-create "*server*") + :noquery t + :family 'local + :service file))) + (should (equal (process-contact server :local) file)) + (delete-file (process-contact server :local)))) + +(ert-deftest make-local-tcp-server-with-unspecified-port () + (let ((server + (make-network-process + :name "server" + :server t + :noquery t + :family 'ipv4 + :service t + :host 'local))) + (should (and (arrayp (process-contact server :local)) + (numberp (aref (process-contact server :local) 4)) + (> (aref (process-contact server :local) 4) 0))) + (delete-process server))) + +(ert-deftest make-local-tcp-server-with-specified-port () + (let ((server + (make-network-process + :name "server" + :server t + :noquery t + :family 'ipv4 + :service 57869 + :host 'local))) + (should (and (arrayp (process-contact server :local)) + (= (aref (process-contact server :local) 4) 57869))) + (delete-process server))) + +(defun make-server (host) + (make-network-process + :name "server" + :server t + :noquery t + :family 'ipv4 + :coding 'raw-text-unix + :buffer (get-buffer-create "*server*") + :service t + :sentinel 'server-sentinel + :filter 'server-process-filter + :host host)) + +(defun server-sentinel (proc msg) + ) + +(defun server-process-filter (proc string) + (message "Received %s" string) + (let ((prev (process-get proc 'previous-string))) + (when prev + (setq string (concat prev string)) + (process-put proc 'previous-string nil))) + (if (and (not (string-match "\n" string)) + (> (length string) 0)) + (process-put proc 'previous-string string)) + (let ((command (split-string string))) + (cond + ((equal (car command) "echo") + (process-send-string proc (concat (cadr command) "\n"))) + (t + )))) + +(ert-deftest echo-server-with-dns () + (let* ((server (make-server "mouse")) + (port (aref (process-contact server :local) 4)) + (proc (make-network-process :name "foo" + :buffer (generate-new-buffer "*foo*") + :host (system-name) + :service port))) + (with-current-buffer "*foo*" + (process-send-string proc "echo foo") + (sleep-for 0.1) + (should (equal (buffer-string) "foo\n"))))) + +(ert-deftest echo-server-with-localhost () + (let* ((server (make-server 'local)) + (port (aref (process-contact server :local) 4)) + (proc (make-network-process :name "foo" + :buffer (generate-new-buffer "*foo*") + :host "localhost" + :service port))) + (with-current-buffer "*foo*" + (process-send-string proc "echo foo") + (sleep-for 0.1) + (should (equal (buffer-string) "foo\n"))))) + +(ert-deftest echo-server-with-ip () + (let* ((server (make-server 'local)) + (port (aref (process-contact server :local) 4)) + (proc (make-network-process :name "foo" + :buffer (generate-new-buffer "*foo*") + :host "127.0.0.1" + :service port))) + (with-current-buffer "*foo*" + (process-send-string proc "echo foo") + (sleep-for 0.1) + (should (equal (buffer-string) "foo\n"))))) + +;;; network-stream-tests.el ends here commit 12702b312bdb63b15619fac682f3a2c205b94eba Author: Lars Ingebrigtsen Date: Fri Feb 5 14:03:26 2016 +1100 Make url.el use async DNS * lisp/url/url-gw.el (url-open-stream): Use non-blocking DNS. * src/process.c (syms_of_process): Add a `dns' subfeature for make-network-process. diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el index 460ee0d..4d1dce6 100644 --- a/lisp/url/url-gw.el +++ b/lisp/url/url-gw.el @@ -245,8 +245,9 @@ overriding the value of `url-gateway-method'." name buffer host service :type gw-method ;; Use non-blocking socket if we can. - :nowait (featurep 'make-network-process - '(:nowait t)))) + :nowait (and (featurep 'make-network-process + '(:nowait t)) + 'dns))) (`socks (socks-open-network-stream name buffer host service)) (`telnet diff --git a/src/process.c b/src/process.c index 86ca3f3..9653eba 100644 --- a/src/process.c +++ b/src/process.c @@ -7921,6 +7921,9 @@ The variable takes effect when `start-process' is called. */); #ifdef NON_BLOCKING_CONNECT ADD_SUBFEATURE (QCnowait, Qt); +#ifdef HAVE_GETADDRINFO_A + ADD_SUBFEATURE (QCnowait, Qdns); +#endif #endif #ifdef DATAGRAM_SOCKETS ADD_SUBFEATURE (QCtype, Qdatagram); commit c85e7d4c8c899c01d6b4a393512bab295ef635c1 Author: Lars Ingebrigtsen Date: Fri Feb 5 13:57:28 2016 +1100 Only do async DNS if requested with :nowait 'dns * doc/lispref/processes.texi (Network Processes): Mention the dns value of :nowait. * src/process.c (Fmake_network_process): Only do async DNS if :nowait is `dns'. diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index ccff138..a1c8755 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -2409,8 +2409,8 @@ as it may depend on implementation defined constants, data sizes, and data structure alignment. @end itemize -@item :nowait @var{bool} -If @var{bool} is non-@code{nil} for a stream connection, return +@item :nowait @var{nowait} +If @var{nowait} is non-@code{nil} for a stream connection, return 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 @@ -2418,6 +2418,12 @@ second argument matching @code{"open"} (if successful) or @code{make-network-process} does not return until the connection has succeeded or failed. +If @var{nowait} is @code{dns}, also do the @acronym{DNS} lookup +asynchronously, if supported. In that case, the process is returned +before a connection has been made, and the client should not try +communicating with the process until it has changed status to +@code{"connected"}. + @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 diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el index 4925805..6767446 100644 --- a/lisp/net/network-stream.el +++ b/lisp/net/network-stream.el @@ -136,8 +136,12 @@ 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. If it is `dns', also do the DNS +lookup asynchronously, if supported. In that case, the process +is returned before a connection has been made, and the client +should not try communicating with the process until it has +changed status to \"connected\". :tls-parameters is a list that should be supplied if you're opening a TLS connection. The first element is the TLS diff --git a/src/process.c b/src/process.c index b232e33..86ca3f3 100644 --- a/src/process.c +++ b/src/process.c @@ -3421,11 +3421,16 @@ system used for both reading and writing for this process. If CODING is a cons (DECODING . ENCODING), DECODING is used for reading, and ENCODING is used for writing. -:nowait BOOL -- If BOOL is non-nil for a stream type client process, -return without waiting for the connection to complete; instead, the -sentinel function will be called with second arg matching "open" (if -successful) or "failed" when the connect completes. Default is to use -a blocking connect (i.e. wait) for stream type connections. +:nowait NOWAIT -- If NOWAIT is non-nil for a stream type client +process, return without waiting for the connection to complete; +instead, the sentinel function will be called with second arg matching +"open" (if successful) or "failed" when the connect completes. +Default is to use a blocking connect (i.e. wait) for stream type +connections. If NOWAIT is `dns', also do the DNS lookup +asynchronously, if supported. In that case, the process is returned +before a connection has been made, and the client should not try +communicating with the process until it has changed status to +"connected". :noquery BOOL -- Query the user unless BOOL is non-nil, and process is running when Emacs is exited. @@ -3688,7 +3693,7 @@ usage: (make-network-process &rest ARGS) */) #endif #ifdef HAVE_GETADDRINFO_A - if (!NILP (Fplist_get (contact, QCnowait)) && + if (EQ (Fplist_get (contact, QCnowait), Qdns) && !NILP (host)) { int ret; @@ -4603,7 +4608,7 @@ check_for_dns (Lisp_Object proc) return Qnil; /* This process should not already be connected (or killed). */ - if (p->infd != 0) + if (!EQ (p->status, Qconnect)) return Qnil; ret = gai_error (p->dns_requests[0]); @@ -7752,6 +7757,7 @@ syms_of_process (void) DEFSYM (QCcoding, ":coding"); DEFSYM (QCserver, ":server"); DEFSYM (QCnowait, ":nowait"); + DEFSYM (Qdns, "dns"); DEFSYM (QCsentinel, ":sentinel"); DEFSYM (QCtls_parameters, ":tls-parameters"); DEFSYM (QClog, ":log"); commit e4c58cf3feb853f2808204e85529d9365b31a6b4 Author: Lars Ingebrigtsen Date: Fri Feb 5 13:04:59 2016 +1100 Add sanity check for checking async DNS * src/process.c (check_for_dns): Disregard processes that have already been killed. diff --git a/src/process.c b/src/process.c index 0c8fc43..b232e33 100644 --- a/src/process.c +++ b/src/process.c @@ -4602,6 +4602,10 @@ check_for_dns (Lisp_Object proc) if (! p->dns_requests) return Qnil; + /* This process should not already be connected (or killed). */ + if (p->infd != 0) + return Qnil; + ret = gai_error (p->dns_requests[0]); if (ret == EAI_INPROGRESS) return Qt; commit 894e21df1e1a38244ad0c8179adf4b632b25a592 Author: Lars Ingebrigtsen Date: Wed Feb 3 12:43:24 2016 +1100 Doc fixes and refactorings based on comments from Eli Zaretskii * doc/lispref/processes.texi (Network Processes): Clarify the meaning of :tls-parameters. * lisp/net/gnutls.el (open-gnutls-stream): Clarify :nowait. * lisp/net/gnutls.el (gnutls-boot-parameters): Factor out into own function. (gnutls-negotiate): Use it. (open-gnutls-stream): Ditto. * src/eval.c (vformat_string): Refactor out the printing bits from verror. (verror): Use it. * src/gnutls.c (boot_error): Mark failed processes with the real error message. * src/lisp.h: Declare vformat_string. diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index e77da77..ccff138 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -2420,9 +2420,12 @@ has succeeded or failed. @item :tls-parameters When opening a TLS connection, this should be where the first element -is the TLS type, and the remaining elements should form a keyword list -acceptable for @code{gnutls-boot}. The TLS connection will then be -negotiated after completing the connection to the host. +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 diff --git a/doc/misc/emacs-gnutls.texi b/doc/misc/emacs-gnutls.texi index 75fd97c..115727f 100644 --- a/doc/misc/emacs-gnutls.texi +++ b/doc/misc/emacs-gnutls.texi @@ -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") diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el index 8db6654..8db3450 100644 --- a/lisp/net/gnutls.el +++ b/lisp/net/gnutls.el @@ -110,7 +110,8 @@ 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. +be opened asynchronously. The connection process will be +returned to the caller before TLS negotiation has happened. Usage example: @@ -129,12 +130,13 @@ trust and key files, and priority string." :nowait nowait :tls-parameters (and nowait - (gnutls-negotiate :type 'gnutls-x509pki - :return-keywords t - :hostname host))))) + (cons 'gnutls-x509pki + (gnutls-boot-parameters + :type 'gnutls-x509pki + :hostname host)))))) (if nowait process - (gnutls-negotiate :process (open-network-stream name buffer host service) + (gnutls-negotiate :process process :type 'gnutls-x509pki :hostname host)))) @@ -149,14 +151,48 @@ trust and key files, and priority string." &key process type hostname priority-string trustfiles crlfiles keylist min-prime-bits verify-flags verify-error verify-hostname-error - return-keywords &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. -TYPE is `gnutls-x509pki' (default) or `gnutls-anon'. Use nil for the default. 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. 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'. @@ -201,71 +237,48 @@ here's a recent version of the list. GNUTLS_VERIFY_DO_NOT_ALLOW_X509_V1_CA_CRT = 256 It must be omitted, a number, or nil; if omitted or nil it -defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT. - -If RETURN-KEYWORDS, don't connect to anything, but just return -the computed parameters that we otherwise would be calling -gnutls-boot with. The return value will be a list where the -first element is the TLS type, and the rest of the list consists -of the keywords." - (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) +defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT." + (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)) - - (if return-keywords - (cons type params) - (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." diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el index acbdb7a..4925805 100644 --- a/lisp/net/network-stream.el +++ b/lisp/net/network-stream.el @@ -140,9 +140,10 @@ a greeting from the server. 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, and -the remaining elements should be a keyword list accepted by -gnutls-boot." +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)) diff --git a/src/eval.c b/src/eval.c index 6c912bc..c01dd09 100644 --- a/src/eval.c +++ b/src/eval.c @@ -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)); } diff --git a/src/gnutls.c b/src/gnutls.c index fb3c3c2..948a0c5 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -1174,7 +1174,7 @@ 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, Qfailed); + pset_status (p, list2 (Qfailed, vformat_string (m, ap))); else verror (m, ap); } diff --git a/src/lisp.h b/src/lisp.h index 02b8078..e87f475 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3908,6 +3908,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); diff --git a/src/process.c b/src/process.c index e4dd123..0c8fc43 100644 --- a/src/process.c +++ b/src/process.c @@ -3454,8 +3454,10 @@ and MESSAGE is a string. :plist PLIST -- Install PLIST as the new process's initial plist. :tls-parameters LIST -- is a list that should be supplied if you're -opening a TLS connection. The first element is the TLS type, and the -remaining elements should be a keyword list accepted by gnutls-boot. +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'). :server QLEN -- if QLEN is non-nil, create a server process for the specified FAMILY, SERVICE, and connection type (stream or datagram). commit eb597d40950d0b8f126641bf458af28fcab150d5 Author: Lars Ingebrigtsen Date: Tue Feb 2 03:17:53 2016 +0100 Build fix for --enable-check-lisp-object-type * process.c (check_for_dns): Type fix reported by YAMAMOTO Mitsuharu. diff --git a/src/process.c b/src/process.c index 762778e..e4dd123 100644 --- a/src/process.c +++ b/src/process.c @@ -4598,7 +4598,7 @@ check_for_dns (Lisp_Object proc) /* Sanity check. */ if (! p->dns_requests) - return 1; + return Qnil; ret = gai_error (p->dns_requests[0]); if (ret == EAI_INPROGRESS) commit 3955d6c692d8ef5a0873b42556d8284263ca5794 Author: Lars Ingebrigtsen Date: Tue Feb 2 02:52:03 2016 +0100 Boot parameter check fix * process.c (send_process): Fix test for boot parameters noted by Andy Moreton. diff --git a/src/process.c b/src/process.c index 14be3b0..762778e 100644 --- a/src/process.c +++ b/src/process.c @@ -5904,7 +5904,7 @@ send_process (Lisp_Object proc, const char *buf, ptrdiff_t len, #ifdef HAVE_GNUTLS /* The TLS connection hasn't been set up yet, so we can't write anything on the socket. */ - if (p->gnutls_boot_parameters) + if (!NILP (p->gnutls_boot_parameters)) return; #endif commit b75f46418651bee07ad6433ba95602a78ff19e94 Author: Lars Ingebrigtsen Date: Mon Feb 1 06:05:53 2016 +0100 Style fix diff --git a/src/process.c b/src/process.c index 10c79ab..14be3b0 100644 --- a/src/process.c +++ b/src/process.c @@ -3066,13 +3066,14 @@ void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) { Lisp_Object params = contact, key, val; - while (!NILP (params)) { - key = XCAR (params); - params = XCDR (params); - val = XCAR (params); - params = XCDR (params); - optbits |= set_socket_option (s, key, val); - } + while (!NILP (params)) + { + key = XCAR (params); + params = XCDR (params); + val = XCAR (params); + params = XCDR (params); + optbits |= set_socket_option (s, key, val); + } } if (p->is_server) commit 76bf44370e7b1215bb8f6125eea03102fc8f786d Author: Lars Ingebrigtsen Date: Mon Feb 1 05:43:17 2016 +0100 Return the correct server port number * process.c (connect_network_socket): Return the correct server port number. diff --git a/src/process.c b/src/process.c index b6721ad..10c79ab 100644 --- a/src/process.c +++ b/src/process.c @@ -3104,6 +3104,9 @@ void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) Lisp_Object service; service = make_number (ntohs (sa1.sin_port)); contact = Fplist_put (contact, QCservice, service); + // Save the port number so that we can stash it in + // the process object later. + ((struct sockaddr_in *)sa)->sin_port = sa1.sin_port; } } #endif commit 68f1797cab339eb5391b0502270ac20f69fea64e Author: Lars Ingebrigtsen Date: Mon Feb 1 04:53:27 2016 +0100 Fix autoconf test for getaddrinfo_a * configure.ac: Make the test for getaddrinfo_a work. diff --git a/configure.ac b/configure.ac index b00cc1a..1d2b175 100644 --- a/configure.ac +++ b/configure.ac @@ -2408,15 +2408,13 @@ if test "${HAVE_X11}" = "yes" || test "${HAVE_NS}" = "yes" || test "${HAVE_W32}" fi fi -GETADDRINFO_A_LIBS="-lanl" -AC_CHECK_LIB(anl, getaddrinfo_a, HAVE_GETADDRINFO_A=yes, HAVE_GETADDRINFO_A=no, - [$GETADDRINFO_A_LIBS]) -AC_SUBST(GETADDRINFO_A_LIBS) - -OLD_LIBS=$LIBS -LIBS="-lanl $LIBS" -AC_CHECK_FUNCS(getaddrinfo_a) -LIBS=$OLD_LIBS +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= commit bf4bbfe16d7d676d56cb9ed661684b17318d333f Author: Lars Ingebrigtsen Date: Mon Feb 1 03:58:03 2016 +0100 Better async error reporting * process.c (connect_network_socket): Mark failed processes with a better error message. (check_for_dns): Ditto. diff --git a/src/process.c b/src/process.c index 8849b20..b6721ad 100644 --- a/src/process.c +++ b/src/process.c @@ -3311,8 +3311,12 @@ void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) p->gnutls_boot_parameters = Qnil; boot = Fgnutls_boot (proc, XCAR (params), XCDR (params)); if (NILP (boot) || STRINGP (boot)) { - pset_status (p, Qfailed); deactivate_process (proc); + if (NILP (boot)) + pset_status (p, list2 (Qfailed, + build_string ("TLS negotiation failed"))); + else + pset_status (p, list2 (Qfailed, boot)); } } #endif @@ -4614,8 +4618,12 @@ check_for_dns (Lisp_Object proc) /* The DNS lookup failed. */ else { - pset_status (p, Qfailed); deactivate_process (proc); + pset_status (p, (list2 + (Qfailed, + concat3 (build_string ("Name lookup of "), + build_string (p->dns_requests[0]->ar_name), + build_string (" failed"))))); } xfree ((void *)p->dns_requests[0]->ar_request); commit 9de7d90184a88887e1a2262f097cd9278d0bcf16 Author: Lars Ingebrigtsen Date: Mon Feb 1 03:37:31 2016 +0100 Clarify :tls-parameters. diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index b658c88..e77da77 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -2421,7 +2421,8 @@ has succeeded or failed. @item :tls-parameters When opening a TLS connection, this should be where the first element is the TLS type, and the remaining elements should form a keyword list -acceptable for @code{gnutls-boot}. +acceptable for @code{gnutls-boot}. 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 commit 42ef3013781146c62ece536c10c50bb5a5dc1f78 Author: Lars Ingebrigtsen Date: Mon Feb 1 03:26:09 2016 +0100 Always boot TLS if given parameters * src/process.c (connect_network_socket): If we have the TLS parameters, then boot the socket. diff --git a/src/gnutls.c b/src/gnutls.c index a0b6e0d..fb3c3c2 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -695,7 +695,7 @@ to finish setting up the connection. */) { CHECK_PROCESS (proc); - XPROCESS (proc)->gnutls_async_parameters = params; + XPROCESS (proc)->gnutls_boot_parameters = params; return Qnil; } diff --git a/src/process.c b/src/process.c index 13f4b6a..8849b20 100644 --- a/src/process.c +++ b/src/process.c @@ -710,7 +710,7 @@ make_process (Lisp_Object name) #ifdef HAVE_GNUTLS p->gnutls_initstage = GNUTLS_STAGE_EMPTY; - p->gnutls_async_parameters = Qnil; + p->gnutls_boot_parameters = Qnil; #endif /* If name is already in use, modify it until it is unused. */ @@ -3304,16 +3304,17 @@ void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) #ifdef HAVE_GNUTLS /* Continue the asynchronous connection. */ - if (!NILP (p->gnutls_async_parameters) && p->is_non_blocking_client) { - Lisp_Object boot, params = p->gnutls_async_parameters; + if (!NILP (p->gnutls_boot_parameters)) + { + Lisp_Object boot, params = p->gnutls_boot_parameters; - p->gnutls_async_parameters = Qnil; - boot = Fgnutls_boot (proc, XCAR (params), XCDR (params)); - if (NILP (boot) || STRINGP (boot)) { - pset_status (p, Qfailed); - deactivate_process (proc); + p->gnutls_boot_parameters = Qnil; + boot = Fgnutls_boot (proc, XCAR (params), XCDR (params)); + if (NILP (boot) || STRINGP (boot)) { + pset_status (p, Qfailed); + deactivate_process (proc); + } } - } #endif } @@ -3831,7 +3832,7 @@ usage: (make-network-process &rest ARGS) */) #ifdef HAVE_GNUTLS tem = Fplist_get (contact, QCtls_parameters); CHECK_LIST (tem); - p->gnutls_async_parameters = tem; + p->gnutls_boot_parameters = tem; #endif unbind_to (count, Qnil); @@ -5891,7 +5892,7 @@ send_process (Lisp_Object proc, const char *buf, ptrdiff_t len, #ifdef HAVE_GNUTLS /* The TLS connection hasn't been set up yet, so we can't write anything on the socket. */ - if (p->gnutls_async_parameters) + if (p->gnutls_boot_parameters) return; #endif diff --git a/src/process.h b/src/process.h index 828330b..c753157 100644 --- a/src/process.h +++ b/src/process.h @@ -106,7 +106,7 @@ struct Lisp_Process #ifdef HAVE_GNUTLS Lisp_Object gnutls_cred_type; - Lisp_Object gnutls_async_parameters; + Lisp_Object gnutls_boot_parameters; #endif /* Pipe process attached to the standard error of this process. */ commit 072d5357c15587af00eeba31033ef5b83d014223 Author: Lars Ingebrigtsen Date: Mon Feb 1 03:15:36 2016 +0100 Add documentation for :tls-parameters * doc/lispref/processes.texi (Network Processes): Mention :tls-parameters. * src/process.c (Fmake_network_process): Document the :tls-parameters parameter. diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index f660b15..b658c88 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -2418,6 +2418,11 @@ second argument matching @code{"open"} (if successful) or @code{make-network-process} does not return until the connection has succeeded or failed. +@item :tls-parameters +When opening a TLS connection, this should be where the first element +is the TLS type, and the remaining elements should form a keyword list +acceptable for @code{gnutls-boot}. + @item :stop @var{stopped} If @var{stopped} is non-@code{nil}, start the network connection or server in the stopped state. diff --git a/src/process.c b/src/process.c index 0e4fcb2..13f4b6a 100644 --- a/src/process.c +++ b/src/process.c @@ -3444,6 +3444,10 @@ and MESSAGE is a string. :plist PLIST -- Install PLIST as the new process's initial plist. +:tls-parameters LIST -- is a list that should be supplied if you're +opening a TLS connection. The first element is the TLS type, and the +remaining elements should be a keyword list accepted by gnutls-boot. + :server QLEN -- if QLEN is non-nil, create a server process for the specified FAMILY, SERVICE, and connection type (stream or datagram). If QLEN is an integer, it is used as the max. length of the server's commit 2cc69b4573573f464e5d21c9f47570afa9c2e7b0 Author: Lars Ingebrigtsen Date: Mon Feb 1 03:06:58 2016 +0100 Build fix for glibc systems. diff --git a/src/process.c b/src/process.c index 5fee8b0..0e4fcb2 100644 --- a/src/process.c +++ b/src/process.c @@ -3318,6 +3318,7 @@ void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) } +#ifndef HAVE_GETADDRINFO static Lisp_Object conv_numerical_to_lisp (unsigned char *number, unsigned int length, int port) { @@ -3331,6 +3332,7 @@ conv_numerical_to_lisp (unsigned char *number, unsigned int length, int port) return address; } +#endif /* Create a network stream/datagram client/server process. Treated exactly like a normal process when reading and writing. Primary @@ -3699,6 +3701,7 @@ usage: (make-network-process &rest ARGS) */) if (!NILP (host)) { struct addrinfo *res, *lres; + int ret; immediate_quit = 1; QUIT; commit 0645c0f81b795ca2e8a44b7ad490d2aba502a489 Author: Lars Ingebrigtsen Date: Mon Feb 1 02:57:04 2016 +0100 Make network connections work again on non-glibc systems * lisp/net/gnutls.el (open-gnutls-stream): Pass the TLS keywords in directly so that they can be used when doing synchronous DNS on non-synchronous connections. * lisp/net/network-stream.el (open-network-stream): Allow passing in the TLS parameters directly. * src/process.c (conv_numerical_to_lisp): New function to convert numerical addresses to Lisp. (Fmake_network_process): Rework the non-HAVE_ADDRINFO code paths so that they work again. (syms_of_process): Build fix for non-glibc systems. diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el index 9cfa825..8db6654 100644 --- a/lisp/net/gnutls.el +++ b/lisp/net/gnutls.el @@ -124,16 +124,16 @@ 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." - (let ((process (open-network-stream name buffer host service - :nowait nowait))) + (let ((process (open-network-stream + name buffer host service + :nowait nowait + :tls-parameters + (and nowait + (gnutls-negotiate :type 'gnutls-x509pki + :return-keywords t + :hostname host))))) (if nowait - (progn - (gnutls-asynchronous-parameters - process - (gnutls-negotiate :type 'gnutls-x509pki - :return-keywords t - :hostname host)) - process) + process (gnutls-negotiate :process (open-network-stream name buffer host service) :type 'gnutls-x509pki :hostname host)))) diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el index 02af884..acbdb7a 100644 --- a/lisp/net/network-stream.el +++ b/lisp/net/network-stream.el @@ -137,7 +137,12 @@ non-nil, is used warn the user if the connection isn't encrypted. a greeting from the server. :nowait is a boolean that says the connection should be made -asynchronously, if possible." +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, and +the remaining elements should be a keyword list accepted by +gnutls-boot." (unless (featurep 'make-network-process) (error "Emacs was compiled without networking support")) (let ((type (plist-get parameters :type)) @@ -150,7 +155,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) diff --git a/src/process.c b/src/process.c index 6b76559..5fee8b0 100644 --- a/src/process.c +++ b/src/process.c @@ -3303,12 +3303,13 @@ void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) set_network_socket_coding_system (proc); #ifdef HAVE_GNUTLS + /* Continue the asynchronous connection. */ if (!NILP (p->gnutls_async_parameters) && p->is_non_blocking_client) { - Lisp_Object params = p->gnutls_async_parameters, boot = Qnil; + Lisp_Object boot, params = p->gnutls_async_parameters; - p->gnutls_async_parameters = Qnil; + p->gnutls_async_parameters = Qnil; boot = Fgnutls_boot (proc, XCAR (params), XCDR (params)); - if (STRINGP (boot)) { + if (NILP (boot) || STRINGP (boot)) { pset_status (p, Qfailed); deactivate_process (proc); } @@ -3317,6 +3318,19 @@ void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) } +static Lisp_Object +conv_numerical_to_lisp (unsigned char *number, unsigned int length, int port) +{ + Lisp_Object address = Fmake_vector (make_number (length + 1), Qnil); + register struct Lisp_Vector *p = XVECTOR (address); + int i; + + p->contents[length] = make_number (port); + for (i = 0; i < length; i++) + p->contents[i] = make_number (*(number + i)); + + return address; +} /* Create a network stream/datagram client/server process. Treated exactly like a normal process when reading and writing. Primary @@ -3490,7 +3504,6 @@ usage: (make-network-process &rest ARGS) */) struct sockaddr_un address_un; #endif int port = 0; - int ret = 0; Lisp_Object tem; Lisp_Object name, buffer, host, service, address; Lisp_Object filter, sentinel; @@ -3661,6 +3674,8 @@ usage: (make-network-process &rest ARGS) */) if (!NILP (Fplist_get (contact, QCnowait)) && !NILP (host)) { + int ret; + printf("Async DNS for '%s'\n", SSDATA (host)); dns_requests = xmalloc (sizeof (struct gaicb*)); dns_requests[0] = xmalloc (sizeof (struct gaicb)); @@ -3724,7 +3739,7 @@ usage: (make-network-process &rest ARGS) */) if (EQ (service, Qt)) port = 0; else if (INTEGERP (service)) - port = htons ((unsigned short) XINT (service)); + port = (unsigned short) XINT (service); else { struct servent *svc_info; @@ -3733,7 +3748,7 @@ usage: (make-network-process &rest ARGS) */) (socktype == SOCK_DGRAM ? "udp" : "tcp")); if (svc_info == 0) error ("Unknown service: %s", SDATA (service)); - port = svc_info->s_port; + port = ntohs (svc_info->s_port); } #ifndef HAVE_GETADDRINFO @@ -3750,24 +3765,29 @@ usage: (make-network-process &rest ARGS) */) res_init (); #endif - host_info_ptr = gethostbyname (SDATA (host)); + host_info_ptr = gethostbyname ((const char *) SDATA (host)); immediate_quit = 0; if (host_info_ptr) { - ip_addresses = Ncons (make_number (host_info_ptr->h_addr, - host_info_ptr->h_length), + ip_addresses = Fcons (conv_numerical_to_lisp + ((unsigned char *) host_info_ptr->h_addr, + host_info_ptr->h_length, + port), Qnil); } else - /* Attempt to interpret host as numeric inet address. */ + /* Attempt to interpret host as numeric inet address. This + only works for IPv4 addresses. */ { - unsigned long numeric_addr; - numeric_addr = inet_addr (SSDATA (host)); + unsigned long numeric_addr = inet_addr (SSDATA (host)); + if (numeric_addr == -1) error ("Unknown host \"%s\"", SDATA (host)); - ip_addresses = Ncons (make_number (numeric_addr), Qnil); + ip_addresses = Fcons (conv_numerical_to_lisp + ((unsigned char *) &numeric_addr, 4, port), + Qnil); } } @@ -3802,7 +3822,9 @@ usage: (make-network-process &rest ARGS) */) p->dns_requests = NULL; #endif #ifdef HAVE_GNUTLS - p->gnutls_async_parameters = Qnil; + tem = Fplist_get (contact, QCtls_parameters); + CHECK_LIST (tem); + p->gnutls_async_parameters = tem; #endif unbind_to (count, Qnil); @@ -7705,6 +7727,7 @@ syms_of_process (void) DEFSYM (QCserver, ":server"); DEFSYM (QCnowait, ":nowait"); DEFSYM (QCsentinel, ":sentinel"); + DEFSYM (QCtls_parameters, ":tls-parameters"); DEFSYM (QClog, ":log"); DEFSYM (QCnoquery, ":noquery"); DEFSYM (QCstop, ":stop"); @@ -7719,7 +7742,9 @@ syms_of_process (void) staticpro (&Vprocess_alist); staticpro (&deleted_pid_list); +#ifdef HAVE_GETADDRINFO_A staticpro (&dns_processes); +#endif #endif /* subprocesses */ commit 56cd5301f1ec70958fa0c2e51ce58c674e800a50 Author: Lars Ingebrigtsen Date: Mon Feb 1 01:19:42 2016 +0100 Windows build fix * process.c (Fmake_network_process): Build fix for systems without local sockets. diff --git a/src/process.c b/src/process.c index b91e1c9..6b76559 100644 --- a/src/process.c +++ b/src/process.c @@ -3587,7 +3587,9 @@ usage: (make-network-process &rest ARGS) */) { /* The "connection" function gets it bind info from the address we're given, so use this dummy address if nothing is specified. */ +#ifdef HAVE_LOCAL_SOCKETS if (family != AF_LOCAL) +#endif host = build_string ("127.0.0.1"); } else commit b11531e99ffb65c99d0cc162bf03497b87fbd347 Author: Lars Ingebrigtsen Date: Mon Feb 1 01:15:43 2016 +0100 Use XCAR/XCDR instead of Fcar etc diff --git a/src/process.c b/src/process.c index afb9825..b91e1c9 100644 --- a/src/process.c +++ b/src/process.c @@ -3018,8 +3018,8 @@ void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) while (!NILP (ip_addresses)) { - ip_address = Fcar (ip_addresses); - ip_addresses = Fcdr (ip_addresses); + ip_address = XCAR (ip_addresses); + ip_addresses = XCDR (ip_addresses); #ifdef WINDOWSNT retry_connect: @@ -3067,10 +3067,10 @@ void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) Lisp_Object params = contact, key, val; while (!NILP (params)) { - key = Fcar (params); - params = Fcdr (params); - val = Fcar (params); - params = Fcdr (params); + key = XCAR (params); + params = XCDR (params); + val = XCAR (params); + params = XCDR (params); optbits |= set_socket_option (s, key, val); } } @@ -3307,7 +3307,7 @@ void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) Lisp_Object params = p->gnutls_async_parameters, boot = Qnil; p->gnutls_async_parameters = Qnil; - boot = Fgnutls_boot (proc, Fcar (params), Fcdr (params)); + boot = Fgnutls_boot (proc, XCAR (params), XCDR (params)); if (STRINGP (boot)) { pset_status (p, Qfailed); deactivate_process (proc); @@ -4736,8 +4736,8 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, whether we got any answers. */ while (!NILP (dns_list)) { - dns = Fcar (dns_list); - dns_list = Fcdr (dns_list); + dns = XCAR (dns_list); + dns_list = XCDR (dns_list); p = XPROCESS (dns); if (p && p->dns_requests) { @@ -4762,10 +4762,10 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, requests. */ while (!NILP (answers)) { - answer = Fcar (answers); - answers = Fcdr (answers); - if (!NILP (Fcdr (answer))) - connect_network_socket (Fcar (answer), Fcdr (answer)); + answer = XCAR (answers); + answers = XCDR (answers); + if (!NILP (XCDR (answer))) + connect_network_socket (XCAR (answer), XCDR (answer)); } } #endif /* HAVE_GETADDRINFO_A */ commit 8858b2ce88bec90932c06de60b76584352f73bd6 Author: Lars Ingebrigtsen Date: Mon Feb 1 01:10:57 2016 +0100 Fix GC problem in async TLS connection * process.h: All Lisp_Object slots have to come first, otherwise they won't be protected from gc. diff --git a/src/process.h b/src/process.h index 95c64fa..828330b 100644 --- a/src/process.h +++ b/src/process.h @@ -106,6 +106,7 @@ struct Lisp_Process #ifdef HAVE_GNUTLS Lisp_Object gnutls_cred_type; + Lisp_Object gnutls_async_parameters; #endif /* Pipe process attached to the standard error of this process. */ @@ -191,7 +192,6 @@ struct Lisp_Process unsigned int gnutls_extra_peer_verification; int gnutls_log_level; int gnutls_handshakes_tried; - Lisp_Object gnutls_async_parameters; bool_bf gnutls_p : 1; #endif }; commit 4ff81f8fac1270a829bb2725911bf6b614711257 Author: Lars Ingebrigtsen Date: Mon Feb 1 00:27:07 2016 +0100 Further TLS async work * gnutls.c (boot_error): New function to either signal an error or return an error code. (Fgnutls_boot): Don't signal errors when running asynchronously. * process.h (pset_status): Move here from process.c to be able to use from gnutls.c. * process.c (connect_network_socket): Do the TLS boot here when running asynchronously. (wait_reading_process_output): Rework the dns_processes handling for more safety. diff --git a/src/gnutls.c b/src/gnutls.c index 06459fb..a0b6e0d 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -1167,6 +1167,19 @@ 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, Qfailed); + else + verror (m, ap); +} + + 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 @@ -1246,16 +1259,23 @@ one trustfile (usually a CA bundle). */) 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); @@ -1272,11 +1292,15 @@ one trustfile (usually a CA bundle). */) } else if (NILP (Flistp (verify_error))) { - error ("gnutls-boot: invalid :verify_error parameter (not a list)"); + boot_error (p, "gnutls-boot: invalid :verify_error parameter (not a list)"); + return Qnil; } 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; @@ -1384,7 +1408,8 @@ one trustfile (usually a CA bundle). */) else { emacs_gnutls_deinit (proc); - error ("Invalid trustfile"); + boot_error (p, "Invalid trustfile"); + return Qnil; } } @@ -1408,7 +1433,8 @@ one trustfile (usually a CA bundle). */) else { emacs_gnutls_deinit (proc); - error ("Invalid CRL file"); + boot_error (p, "Invalid CRL file"); + return Qnil; } } @@ -1437,8 +1463,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; } } } @@ -1528,8 +1555,9 @@ one trustfile (usually a CA bundle). */) || !NILP (Fmember (QCgnutls_bootprop_trustfiles, verify_error))) { emacs_gnutls_deinit (proc); - error ("Certificate validation failed %s, verification code %x", - c_hostname, peer_verification); + boot_error (p, "Certificate validation failed %s, verification code %x", + c_hostname, peer_verification); + return Qnil; } else { @@ -1558,7 +1586,8 @@ one trustfile (usually a CA bundle). */) { gnutls_x509_crt_deinit (gnutls_verify_cert); emacs_gnutls_deinit (proc); - error ("No x509 certificate was found\n"); + boot_error (p, "No x509 certificate was found\n"); + return Qnil; } /* We only check the first certificate in the given chain. */ @@ -1586,7 +1615,8 @@ one trustfile (usually a CA bundle). */) { gnutls_x509_crt_deinit (gnutls_verify_cert); emacs_gnutls_deinit (proc); - error ("The x509 certificate does not match \"%s\"", c_hostname); + boot_error (p, "The x509 certificate does not match \"%s\"", c_hostname); + return Qnil; } else { diff --git a/src/process.c b/src/process.c index 5526405..afb9825 100644 --- a/src/process.c +++ b/src/process.c @@ -385,11 +385,6 @@ pset_sentinel (struct Lisp_Process *p, Lisp_Object val) p->sentinel = NILP (val) ? Qinternal_default_process_sentinel : val; } static void -pset_status (struct Lisp_Process *p, Lisp_Object val) -{ - p->status = val; -} -static void pset_tty_name (struct Lisp_Process *p, Lisp_Object val) { p->tty_name = val; @@ -3309,11 +3304,17 @@ void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) #ifdef HAVE_GNUTLS if (!NILP (p->gnutls_async_parameters) && p->is_non_blocking_client) { - Fgnutls_boot (proc, Fcar (p->gnutls_async_parameters), - Fcdr (p->gnutls_async_parameters)); + Lisp_Object params = p->gnutls_async_parameters, boot = Qnil; + p->gnutls_async_parameters = Qnil; + boot = Fgnutls_boot (proc, Fcar (params), Fcdr (params)); + if (STRINGP (boot)) { + pset_status (p, Qfailed); + deactivate_process (proc); + } } #endif + } @@ -3798,6 +3799,9 @@ usage: (make-network-process &rest ARGS) */) #ifdef HAVE_GETADDRINFO_A p->dns_requests = NULL; #endif +#ifdef HAVE_GNUTLS + p->gnutls_async_parameters = Qnil; +#endif unbind_to (count, Qnil); @@ -4545,13 +4549,12 @@ server_accept_connection (Lisp_Object server, int channel) } #ifdef HAVE_GETADDRINFO_A -static int +static Lisp_Object check_for_dns (Lisp_Object proc) { struct Lisp_Process *p = XPROCESS (proc); Lisp_Object ip_addresses = Qnil; int ret = 0; - int connect = 0; /* Sanity check. */ if (! p->dns_requests) @@ -4559,7 +4562,7 @@ check_for_dns (Lisp_Object proc) ret = gai_error (p->dns_requests[0]); if (ret == EAI_INPROGRESS) - return 0; + return Qt; /* We got a response. */ if (ret == 0) @@ -4575,10 +4578,13 @@ check_for_dns (Lisp_Object proc) ip_addresses = Fnreverse (ip_addresses); freeaddrinfo (p->dns_requests[0]->ar_result); - connect = 1; } + /* The DNS lookup failed. */ else - pset_status (p, Qfailed); + { + pset_status (p, Qfailed); + deactivate_process (proc); + } xfree ((void *)p->dns_requests[0]->ar_request); xfree ((void *)p->dns_requests[0]->ar_name); @@ -4587,10 +4593,7 @@ check_for_dns (Lisp_Object proc) xfree (p->dns_requests); p->dns_requests = NULL; - if (connect) - connect_network_socket (proc, ip_addresses); - - return 1; + return ip_addresses; } #endif /* HAVE_GETADDRINFO_A */ @@ -4722,18 +4725,47 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, #ifdef HAVE_GETADDRINFO_A if (!NILP (dns_processes)) { - Lisp_Object dns_list = dns_processes, dns; + Lisp_Object dns_list = dns_processes, dns, ip_addresses, + answers = Qnil, answer, new = Qnil; struct Lisp_Process *p; + /* This is programmed in a somewhat awkward fashion because + calling connect_network_socket might make us end up back + here again, and we would have a race condition with + segfaults. So first go through all pending requests and see + whether we got any answers. */ while (!NILP (dns_list)) { dns = Fcar (dns_list); dns_list = Fcdr (dns_list); p = XPROCESS (dns); - if (p && p->dns_requests && - (! wait_proc || p == wait_proc) && - check_for_dns (dns)) - dns_processes = Fdelq (dns, dns_processes); + if (p && p->dns_requests) + { + if (! wait_proc || p == wait_proc) + { + ip_addresses = check_for_dns (dns); + if (EQ (ip_addresses, Qt)) + new = Fcons (dns, new); + else + answers = Fcons (Fcons (dns, ip_addresses), answers); + } + else + new = Fcons (dns, new); + } + } + + /* Replace with the list of DNS requests still not responded + to. */ + dns_processes = new; + + /* Then continue the connection for the successful + requests. */ + while (!NILP (answers)) + { + answer = Fcar (answers); + answers = Fcdr (answers); + if (!NILP (Fcdr (answer))) + connect_network_socket (Fcar (answer), Fcdr (answer)); } } #endif /* HAVE_GETADDRINFO_A */ @@ -7685,6 +7717,7 @@ syms_of_process (void) staticpro (&Vprocess_alist); staticpro (&deleted_pid_list); + staticpro (&dns_processes); #endif /* subprocesses */ diff --git a/src/process.h b/src/process.h index eb34f5f..95c64fa 100644 --- a/src/process.h +++ b/src/process.h @@ -210,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) commit 9972329387b7f1e1a9b1c8713a1d5bbdd032de12 Author: Lars Ingebrigtsen Date: Mon Feb 1 00:23:33 2016 +0100 Clean up dead code * lisp/net/gnutls.el (gnutls-async-sentinel): Remove. diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el index 9e261a7..9cfa825 100644 --- a/lisp/net/gnutls.el +++ b/lisp/net/gnutls.el @@ -138,13 +138,6 @@ trust and key files, and priority string." :type 'gnutls-x509pki :hostname host)))) -(defun gnutls-async-sentinel (process change) - (when (string-match "open" change) - (gnutls-negotiate :process process - :type 'gnutls-x509pki - :hostname (car (process-contact process))) - (gnutls-mark-process process nil))) - (define-error 'gnutls-error "GnuTLS error") (declare-function gnutls-boot "gnutls.c" (proc type proplist)) commit cecf6c9ac58ecd9ea251241a6b8a18e0e01dbc2a Author: Lars Ingebrigtsen Date: Sun Jan 31 02:32:21 2016 +0100 Rework the mechanisms for async GnuTLS connections * lisp/net/gnutls.el (open-gnutls-stream): Compute the gnutls-boot parameters and pass them to the process object. (gnutls-negotiate): New parameter :return-keywords that won't connect to anything, just compute the keywords. * lisp/url/url-http.el (url-http): Revert async TLS sentinel hack, which is no longer necessary. * src/gnutls.c (Fgnutls_asynchronous_parameters): Rename from gnutls-mark-process. * src/process.c (connect_network_socket): If we're connecting to an asynchronous TLS socket, complete the GnuTLS boot sequence here. * src/process.h: New parameter gnutls_async_parameters. diff --git a/doc/misc/emacs-gnutls.texi b/doc/misc/emacs-gnutls.texi index 1db6c51..75fd97c 100644 --- a/doc/misc/emacs-gnutls.texi +++ b/doc/misc/emacs-gnutls.texi @@ -181,9 +181,6 @@ 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. -If called with @var{nowait}, the process is returned immediately -(before connecting to the server). - @lisp ;; open a HTTPS connection (open-gnutls-stream "tls" "tls-buffer" "yourserver.com" "https") @@ -194,6 +191,12 @@ If called with @var{nowait}, the process is returned immediately @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. diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el index 90bfe04..9e261a7 100644 --- a/lisp/net/gnutls.el +++ b/lisp/net/gnutls.el @@ -128,8 +128,11 @@ trust and key files, and priority string." :nowait nowait))) (if nowait (progn - (gnutls-mark-process process t) - (set-process-sentinel process 'gnutls-async-sentinel) + (gnutls-asynchronous-parameters + process + (gnutls-negotiate :type 'gnutls-x509pki + :return-keywords t + :hostname host)) process) (gnutls-negotiate :process (open-network-stream name buffer host service) :type 'gnutls-x509pki @@ -153,6 +156,7 @@ trust and key files, and priority string." &key process type hostname priority-string trustfiles crlfiles keylist min-prime-bits verify-flags verify-error verify-hostname-error + return-keywords &allow-other-keys) "Negotiate a SSL/TLS connection. Returns proc. Signals gnutls-error. @@ -204,7 +208,13 @@ here's a recent version of the list. GNUTLS_VERIFY_DO_NOT_ALLOW_X509_V1_CA_CRT = 256 It must be omitted, a number, or nil; if omitted or nil it -defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT." +defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT. + +If RETURN-KEYWORDS, don't connect to anything, but just return +the computed parameters that we otherwise would be calling +gnutls-boot with. The return value will be a list where the +first element is the TLS type, and the rest of the list consists +of the keywords." (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. @@ -252,15 +262,17 @@ defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT." :verify-error ,verify-error :callbacks nil)) - (gnutls-message-maybe - (setq ret (gnutls-boot process type params)) - "boot: %s" params) + (if return-keywords + (cons type params) + (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))) + (when (gnutls-errorp ret) + ;; This is a error from the underlying C code. + (signal 'gnutls-error (list process ret))) - process)) + process))) (defun gnutls-trustfiles () "Return a list of usable trustfiles." diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index 43b2862..222dbc6 100644 --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el @@ -1277,17 +1277,7 @@ The return value of this function is the retrieval buffer." (pcase (process-status connection) (`connect ;; Asynchronous connection - (if (not (process-sentinel connection)) - (set-process-sentinel connection 'url-http-async-sentinel) - ;; If we already have a sentinel on this process (for - ;; instance on TLS connections), then chain them - ;; together. - (let ((old (process-sentinel connection))) - (set-process-sentinel - connection - `(lambda (proc why) - (funcall ',old proc why) - (url-http-async-sentinel proc why)))))) + (set-process-sentinel connection 'url-http-async-sentinel)) (`failed ;; Asynchronous connection failed (error "Could not create connection to %s:%d" host port)) diff --git a/src/gnutls.c b/src/gnutls.c index d11b11c..06459fb 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -686,13 +686,16 @@ emacs_gnutls_deinit (Lisp_Object proc) return Qt; } -DEFUN ("gnutls-mark-process", Fgnutls_mark_process, Sgnutls_mark_process, 2, 2, 0, - doc: /* Mark this process as being a pre-init GnuTLS process. */) - (Lisp_Object proc, Lisp_Object state) +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_wait_p = !NILP (state); + XPROCESS (proc)->gnutls_async_parameters = params; return Qnil; } @@ -1703,7 +1706,7 @@ syms_of_gnutls (void) make_number (GNUTLS_E_APPLICATION_ERROR_MIN)); defsubr (&Sgnutls_get_initstage); - defsubr (&Sgnutls_mark_process); + defsubr (&Sgnutls_asynchronous_parameters); defsubr (&Sgnutls_errorp); defsubr (&Sgnutls_error_fatalp); defsubr (&Sgnutls_error_string); diff --git a/src/process.c b/src/process.c index a30dd23..5526405 100644 --- a/src/process.c +++ b/src/process.c @@ -715,6 +715,7 @@ make_process (Lisp_Object name) #ifdef HAVE_GNUTLS p->gnutls_initstage = GNUTLS_STAGE_EMPTY; + p->gnutls_async_parameters = Qnil; #endif /* If name is already in use, modify it until it is unused. */ @@ -3305,6 +3306,14 @@ void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) max_process_desc = inch; set_network_socket_coding_system (proc); + +#ifdef HAVE_GNUTLS + if (!NILP (p->gnutls_async_parameters) && p->is_non_blocking_client) { + Fgnutls_boot (proc, Fcar (p->gnutls_async_parameters), + Fcdr (p->gnutls_async_parameters)); + p->gnutls_async_parameters = Qnil; + } +#endif } @@ -5817,7 +5826,9 @@ send_process (Lisp_Object proc, const char *buf, ptrdiff_t len, error ("Output file descriptor of %s is closed", SDATA (p->name)); #ifdef HAVE_GNUTLS - if (p->gnutls_wait_p) + /* The TLS connection hasn't been set up yet, so we can't write + anything on the socket. */ + if (p->gnutls_async_parameters) return; #endif diff --git a/src/process.h b/src/process.h index 8bd555b..eb34f5f 100644 --- a/src/process.h +++ b/src/process.h @@ -191,8 +191,8 @@ struct Lisp_Process unsigned int gnutls_extra_peer_verification; int gnutls_log_level; int gnutls_handshakes_tried; + Lisp_Object gnutls_async_parameters; bool_bf gnutls_p : 1; - bool_bf gnutls_wait_p : 1; #endif }; commit 1f71df7aacf15dbf242c74a4b7a7ac8fe0984a3c Author: Lars Ingebrigtsen Date: Sun Jan 31 02:00:12 2016 +0100 Fix segfault from double free * process.c (check_for_dns): Protect against double free issues. diff --git a/src/process.c b/src/process.c index 0fe4518..a30dd23 100644 --- a/src/process.c +++ b/src/process.c @@ -4542,6 +4542,11 @@ check_for_dns (Lisp_Object proc) struct Lisp_Process *p = XPROCESS (proc); Lisp_Object ip_addresses = Qnil; int ret = 0; + int connect = 0; + + /* Sanity check. */ + if (! p->dns_requests) + return 1; ret = gai_error (p->dns_requests[0]); if (ret == EAI_INPROGRESS) @@ -4561,7 +4566,7 @@ check_for_dns (Lisp_Object proc) ip_addresses = Fnreverse (ip_addresses); freeaddrinfo (p->dns_requests[0]->ar_result); - connect_network_socket (proc, ip_addresses); + connect = 1; } else pset_status (p, Qfailed); @@ -4571,6 +4576,11 @@ check_for_dns (Lisp_Object proc) xfree ((void *)p->dns_requests[0]->ar_service); xfree (p->dns_requests[0]); xfree (p->dns_requests); + p->dns_requests = NULL; + + if (connect) + connect_network_socket (proc, ip_addresses); + return 1; } #endif /* HAVE_GETADDRINFO_A */ commit e2d0ccc96e3314d836c7b38fbee4c30eb8ee9dac Author: Lars Ingebrigtsen Date: Sun Jan 31 01:41:33 2016 +0100 Remove debugging diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el index d6b3696..90bfe04 100644 --- a/lisp/net/gnutls.el +++ b/lisp/net/gnutls.el @@ -136,7 +136,6 @@ trust and key files, and priority string." :hostname host)))) (defun gnutls-async-sentinel (process change) - (message "change: %S %s" change (car (process-contact process))) (when (string-match "open" change) (gnutls-negotiate :process process :type 'gnutls-x509pki commit 0f47153b97ae31b82366a857ec2f937c1580b637 Author: Lars Ingebrigtsen Date: Sun Jan 31 01:34:45 2016 +0100 Implement asynchronous GnuTLS connections * doc/misc/emacs-gnutls.texi (Help For Developers): Mention the nowait parameter. * lisp/net/gnutls.el (open-gnutls-stream): Allow asynchronous connections with the new nowait parameter. * lisp/net/network-stream.el (network-stream-open-tls): Pass on :nowait to open-gnutls-stream. * lisp/url/url-http.el (url-http): Don't overwrite the sentinel created by open-gnutls-stream. * src/gnutls.c (Fgnutls_mark_process): New function. * src/process.c (send_process): Don't write to GnuTLS sockets that haven't been initialised yed. * src/process.h: New slot gnutls_wait_p. diff --git a/doc/misc/emacs-gnutls.texi b/doc/misc/emacs-gnutls.texi index 1a850c6..1db6c51 100644 --- a/doc/misc/emacs-gnutls.texi +++ b/doc/misc/emacs-gnutls.texi @@ -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,9 @@ 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. +If called with @var{nowait}, the process is returned immediately +(before connecting to the server). + @lisp ;; open a HTTPS connection (open-gnutls-stream "tls" "tls-buffer" "yourserver.com" "https") diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el index ce44c03..d6b3696 100644 --- a/lisp/net/gnutls.el +++ b/lisp/net/gnutls.el @@ -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,8 @@ 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. Usage example: @@ -122,9 +124,24 @@ 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))) + (if nowait + (progn + (gnutls-mark-process process t) + (set-process-sentinel process 'gnutls-async-sentinel) + process) + (gnutls-negotiate :process (open-network-stream name buffer host service) + :type 'gnutls-x509pki + :hostname host)))) + +(defun gnutls-async-sentinel (process change) + (message "change: %S %s" change (car (process-contact process))) + (when (string-match "open" change) + (gnutls-negotiate :process process + :type 'gnutls-x509pki + :hostname (car (process-contact process))) + (gnutls-mark-process process nil))) (define-error 'gnutls-error "GnuTLS error") diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el index 59ac299..02af884 100644 --- a/lisp/net/network-stream.el +++ b/lisp/net/network-stream.el @@ -359,10 +359,10 @@ 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) diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index 222dbc6..43b2862 100644 --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el @@ -1277,7 +1277,17 @@ The return value of this function is the retrieval buffer." (pcase (process-status connection) (`connect ;; Asynchronous connection - (set-process-sentinel connection 'url-http-async-sentinel)) + (if (not (process-sentinel connection)) + (set-process-sentinel connection 'url-http-async-sentinel) + ;; If we already have a sentinel on this process (for + ;; instance on TLS connections), then chain them + ;; together. + (let ((old (process-sentinel connection))) + (set-process-sentinel + connection + `(lambda (proc why) + (funcall ',old proc why) + (url-http-async-sentinel proc why)))))) (`failed ;; Asynchronous connection failed (error "Could not create connection to %s:%d" host port)) diff --git a/src/gnutls.c b/src/gnutls.c index 01a5983..d11b11c 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -686,6 +686,16 @@ emacs_gnutls_deinit (Lisp_Object proc) return Qt; } +DEFUN ("gnutls-mark-process", Fgnutls_mark_process, Sgnutls_mark_process, 2, 2, 0, + doc: /* Mark this process as being a pre-init GnuTLS process. */) + (Lisp_Object proc, Lisp_Object state) +{ + CHECK_PROCESS (proc); + + XPROCESS (proc)->gnutls_wait_p = !NILP (state); + 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'. */) @@ -1693,6 +1703,7 @@ syms_of_gnutls (void) make_number (GNUTLS_E_APPLICATION_ERROR_MIN)); defsubr (&Sgnutls_get_initstage); + defsubr (&Sgnutls_mark_process); defsubr (&Sgnutls_errorp); defsubr (&Sgnutls_error_fatalp); defsubr (&Sgnutls_error_string); diff --git a/src/process.c b/src/process.c index 8cfa48d..0fe4518 100644 --- a/src/process.c +++ b/src/process.c @@ -5806,6 +5806,11 @@ send_process (Lisp_Object proc, const char *buf, ptrdiff_t len, if (p->outfd < 0) error ("Output file descriptor of %s is closed", SDATA (p->name)); +#ifdef HAVE_GNUTLS + if (p->gnutls_wait_p) + return; +#endif + coding = proc_encode_coding_system[p->outfd]; Vlast_coding_system_used = CODING_ID_NAME (coding->id); diff --git a/src/process.h b/src/process.h index 990bbd5..8bd555b 100644 --- a/src/process.h +++ b/src/process.h @@ -192,6 +192,7 @@ struct Lisp_Process int gnutls_log_level; int gnutls_handshakes_tried; bool_bf gnutls_p : 1; + bool_bf gnutls_wait_p : 1; #endif }; commit cc45809152ab596deb2115369116e573d43c219a Author: Lars Ingebrigtsen Date: Sat Jan 30 09:09:02 2016 +0100 Clean up compilation warnings diff --git a/src/process.c b/src/process.c index 43fb6ab..8cfa48d 100644 --- a/src/process.c +++ b/src/process.c @@ -3489,7 +3489,7 @@ usage: (make-network-process &rest ARGS) */) int family = -1; int ai_protocol = 0; #ifdef HAVE_GETADDRINFO_A - struct gaicb **dns_requests; + struct gaicb **dns_requests = NULL; #endif ptrdiff_t count = SPECPDL_INDEX (); @@ -3819,8 +3819,6 @@ usage: (make-network-process &rest ARGS) */) here will be nil, so we postpone connecting to the server. */ if (!p->is_server && NILP (ip_addresses)) { - int channel; - p->dns_requests = dns_requests; p->status = Qconnect; dns_processes = Fcons (proc, dns_processes); commit 4d430711122c74964a0e22e026bc2cb0b5dad1a1 Author: Lars Ingebrigtsen Date: Sat Jan 30 09:07:24 2016 +0100 Make async resolution more efficient * process.c (wait_reading_process_output): Use a list of process objects instead of looping through an array to check for name resolution. This should be much faster. diff --git a/src/process.c b/src/process.c index f9a822f..43fb6ab 100644 --- a/src/process.c +++ b/src/process.c @@ -283,7 +283,7 @@ static int max_input_desc; static Lisp_Object chan_process[FD_SETSIZE]; #ifdef HAVE_GETADDRINFO_A /* Pending DNS requests. */ -static Lisp_Object dns_process[FD_SETSIZE]; +static Lisp_Object dns_processes; #endif /* Alist of elements (NAME . PROCESS). */ @@ -3823,12 +3823,7 @@ usage: (make-network-process &rest ARGS) */) p->dns_requests = dns_requests; p->status = Qconnect; - for (channel = 0; channel < FD_SETSIZE; ++channel) - if (NILP (dns_process[channel])) - { - dns_process[channel] = proc; - break; - } + dns_processes = Fcons (proc, dns_processes); } else { @@ -4708,17 +4703,20 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, break; #ifdef HAVE_GETADDRINFO_A - for (channel = 0; channel < FD_SETSIZE; ++channel) + if (!NILP (dns_processes)) { - if (! NILP (dns_process[channel])) + Lisp_Object dns_list = dns_processes, dns; + struct Lisp_Process *p; + + while (!NILP (dns_list)) { - struct Lisp_Process *p = XPROCESS (dns_process[channel]); + dns = Fcar (dns_list); + dns_list = Fcdr (dns_list); + p = XPROCESS (dns); if (p && p->dns_requests && (! wait_proc || p == wait_proc) && - check_for_dns (dns_process[channel])) - { - dns_process[channel] = Qnil; - } + check_for_dns (dns)) + dns_processes = Fdelq (dns, dns_processes); } } #endif /* HAVE_GETADDRINFO_A */ @@ -7569,15 +7567,15 @@ init_process_emacs (void) { chan_process[i] = Qnil; proc_buffered_char[i] = -1; -#ifdef HAVE_GETADDRINFO_A - dns_process[i] = Qnil; -#endif } memset (proc_decode_coding_system, 0, sizeof proc_decode_coding_system); memset (proc_encode_coding_system, 0, sizeof proc_encode_coding_system); #ifdef DATAGRAM_SOCKETS memset (datagram_address, 0, sizeof datagram_address); #endif +#ifdef HAVE_GETADDRINFO_A + dns_processes = Qnil; +#endif #if defined (DARWIN_OS) /* PTYs are broken on Darwin < 6, but are sometimes useful for interactive commit e5b34678c42992d01ddd863e57ad5690327e1bc4 Author: Lars Ingebrigtsen Date: Sat Jan 30 05:31:21 2016 +0100 More async memory leaks * src/process.c (check_for_dns): Free even more allocated async stuff. diff --git a/src/process.c b/src/process.c index 7cf701c..f9a822f 100644 --- a/src/process.c +++ b/src/process.c @@ -4574,6 +4574,8 @@ check_for_dns (Lisp_Object proc) pset_status (p, Qfailed); xfree ((void *)p->dns_requests[0]->ar_request); + xfree ((void *)p->dns_requests[0]->ar_name); + xfree ((void *)p->dns_requests[0]->ar_service); xfree (p->dns_requests[0]); xfree (p->dns_requests); return 1; commit c1b235ab6bc9d5ce34abc9bd8a3d658f797c93b1 Author: Lars Ingebrigtsen Date: Sat Jan 30 04:43:10 2016 +0100 Compilation for for systems with getaddrinfo_a * process.c (Fmake_network_process): Make stuff work again on systems with getaddrinfo_a. diff --git a/src/process.c b/src/process.c index 06fb685..7cf701c 100644 --- a/src/process.c +++ b/src/process.c @@ -3834,9 +3834,9 @@ usage: (make-network-process &rest ARGS) */) { connect_network_socket (proc, ip_addresses); } -#endif /* HAVE_GETADDRINFO_A */ - +#else /* HAVE_GETADDRINFO_A */ connect_network_socket (proc, ip_addresses); +#endif return proc; } commit e5b2f25f3560eb6b590de8391b6a71c2178ff591 Author: Lars Ingebrigtsen Date: Sat Jan 30 04:34:48 2016 +0100 Save correct server data * process.c (connect_network_socket): Save the correct contact info for servers. diff --git a/src/process.c b/src/process.c index aef74d3..06fb685 100644 --- a/src/process.c +++ b/src/process.c @@ -3218,7 +3218,7 @@ void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) } #endif - contact = Fplist_put (contact, p->is_server? QCremote: QClocal, + contact = Fplist_put (contact, p->is_server? QClocal: QCremote, conv_sockaddr_to_lisp (sa, addrlen)); #ifdef HAVE_GETSOCKNAME if (!p->is_server) @@ -3577,7 +3577,8 @@ usage: (make-network-process &rest ARGS) */) { /* The "connection" function gets it bind info from the address we're given, so use this dummy address if nothing is specified. */ - host = build_string ("127.0.0.1"); + if (family != AF_LOCAL) + host = build_string ("127.0.0.1"); } else { commit e99dc4a7490a471cbdf421c8b712d8c09479e592 Author: Lars Ingebrigtsen Date: Sat Jan 30 03:57:54 2016 +0100 Compilation for for non-GNU systems * process.c (Fmake_network_process): Make compilation work again on hosts that don't have getaddrinfo_a. diff --git a/src/process.c b/src/process.c index 168d925..aef74d3 100644 --- a/src/process.c +++ b/src/process.c @@ -3785,7 +3785,9 @@ usage: (make-network-process &rest ARGS) */) p->port = port; p->socktype = socktype; p->ai_protocol = ai_protocol; +#ifdef HAVE_GETADDRINFO_A p->dns_requests = NULL; +#endif unbind_to (count, Qnil); @@ -3811,6 +3813,7 @@ usage: (make-network-process &rest ARGS) */) #endif } +#ifdef HAVE_GETADDRINFO_A /* If we're doing async address resolution, the list of addresses here will be nil, so we postpone connecting to the server. */ if (!p->is_server && NILP (ip_addresses)) @@ -3830,6 +3833,9 @@ usage: (make-network-process &rest ARGS) */) { connect_network_socket (proc, ip_addresses); } +#endif /* HAVE_GETADDRINFO_A */ + + connect_network_socket (proc, ip_addresses); return proc; } commit 233e89cf2317a1df410fe01ce20d66293517b500 Author: Lars Ingebrigtsen Date: Sat Jan 30 03:51:04 2016 +0100 Avoid memory leaks in async DNS * process.c (check_for_dns): Free async DNS resources after they've been used. diff --git a/src/process.c b/src/process.c index dafd533..168d925 100644 --- a/src/process.c +++ b/src/process.c @@ -3489,7 +3489,7 @@ usage: (make-network-process &rest ARGS) */) int family = -1; int ai_protocol = 0; #ifdef HAVE_GETADDRINFO_A - struct gaicb *dns_request = NULL; + struct gaicb **dns_requests; #endif ptrdiff_t count = SPECPDL_INDEX (); @@ -3635,8 +3635,7 @@ usage: (make-network-process &rest ARGS) */) portstring = SSDATA (service); } - hints = xmalloc (sizeof (struct addrinfo)); - memset (hints, 0, sizeof (struct addrinfo)); + hints = xzalloc (sizeof (struct addrinfo)); hints->ai_flags = 0; hints->ai_family = family; hints->ai_socktype = socktype; @@ -3649,17 +3648,15 @@ usage: (make-network-process &rest ARGS) */) if (!NILP (Fplist_get (contact, QCnowait)) && !NILP (host)) { - struct gaicb **reqs = xmalloc (sizeof (struct gaicb*)); - printf("Async DNS for '%s'\n", SSDATA (host)); - dns_request = xmalloc (sizeof (struct gaicb)); - reqs[0] = dns_request; - dns_request->ar_name = strdup (SSDATA (host)); - dns_request->ar_service = strdup (portstring); - dns_request->ar_request = hints; - dns_request->ar_result = NULL; - - ret = getaddrinfo_a (GAI_NOWAIT, reqs, 1, NULL); + dns_requests = xmalloc (sizeof (struct gaicb*)); + dns_requests[0] = xmalloc (sizeof (struct gaicb)); + dns_requests[0]->ar_name = strdup (SSDATA (host)); + dns_requests[0]->ar_service = strdup (portstring); + dns_requests[0]->ar_request = hints; + dns_requests[0]->ar_result = NULL; + + ret = getaddrinfo_a (GAI_NOWAIT, dns_requests, 1, NULL); if (ret) error ("%s/%s getaddrinfo_a error %d", SSDATA (host), portstring, ret); @@ -3788,7 +3785,7 @@ usage: (make-network-process &rest ARGS) */) p->port = port; p->socktype = socktype; p->ai_protocol = ai_protocol; - p->dns_request = NULL; + p->dns_requests = NULL; unbind_to (count, Qnil); @@ -3820,7 +3817,7 @@ usage: (make-network-process &rest ARGS) */) { int channel; - p->dns_request = dns_request; + p->dns_requests = dns_requests; p->status = Qconnect; for (channel = 0; channel < FD_SETSIZE; ++channel) if (NILP (dns_process[channel])) @@ -4546,7 +4543,7 @@ check_for_dns (Lisp_Object proc) Lisp_Object ip_addresses = Qnil; int ret = 0; - ret = gai_error (p->dns_request); + ret = gai_error (p->dns_requests[0]); if (ret == EAI_INPROGRESS) return 0; @@ -4555,7 +4552,7 @@ check_for_dns (Lisp_Object proc) { struct addrinfo *res; - for (res = p->dns_request->ar_result; res; res = res->ai_next) + for (res = p->dns_requests[0]->ar_result; res; res = res->ai_next) { ip_addresses = Fcons (conv_sockaddr_to_lisp (res->ai_addr, res->ai_addrlen), @@ -4563,13 +4560,15 @@ check_for_dns (Lisp_Object proc) } ip_addresses = Fnreverse (ip_addresses); - freeaddrinfo (p->dns_request->ar_result); - /* Free the calling array, too? FIXME */ + freeaddrinfo (p->dns_requests[0]->ar_result); connect_network_socket (proc, ip_addresses); - return 1; } + else + pset_status (p, Qfailed); - pset_status (p, Qfailed); + xfree ((void *)p->dns_requests[0]->ar_request); + xfree (p->dns_requests[0]); + xfree (p->dns_requests); return 1; } #endif /* HAVE_GETADDRINFO_A */ @@ -4705,7 +4704,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, if (! NILP (dns_process[channel])) { struct Lisp_Process *p = XPROCESS (dns_process[channel]); - if (p && p->dns_request && + if (p && p->dns_requests && (! wait_proc || p == wait_proc) && check_for_dns (dns_process[channel])) { diff --git a/src/process.h b/src/process.h index 684434c..990bbd5 100644 --- a/src/process.h +++ b/src/process.h @@ -178,7 +178,7 @@ struct Lisp_Process #ifdef HAVE_GETADDRINFO_A /* Whether the socket is waiting for response from an asynchronous DNS call. */ - struct gaicb* dns_request; + struct gaicb **dns_requests; #endif #ifdef HAVE_GNUTLS commit 0677d94e2d55d473e9bbacde009bfd83df0bc67e Author: Lars Ingebrigtsen Date: Sat Jan 30 02:39:52 2016 +0100 * process.c (check_for_dns): Free the result data. diff --git a/src/process.c b/src/process.c index 90e18d7..dafd533 100644 --- a/src/process.c +++ b/src/process.c @@ -4563,12 +4563,14 @@ check_for_dns (Lisp_Object proc) } ip_addresses = Fnreverse (ip_addresses); + freeaddrinfo (p->dns_request->ar_result); + /* Free the calling array, too? FIXME */ connect_network_socket (proc, ip_addresses); return 1; } pset_status (p, Qfailed); - return 0; + return 1; } #endif /* HAVE_GETADDRINFO_A */ commit e9eb6107dbe3c3fa9671f032cd66030aa77409b0 Author: Lars Ingebrigtsen Date: Sat Jan 30 02:25:08 2016 +0100 Fix server connections * process.c (Fmake_network_process): Make creating server listening ports work again. diff --git a/src/process.c b/src/process.c index e40d7a4..90e18d7 100644 --- a/src/process.c +++ b/src/process.c @@ -3573,7 +3573,13 @@ usage: (make-network-process &rest ARGS) */) /* :host HOST -- hostname, ip address, or 'local for localhost. */ host = Fplist_get (contact, QChost); - if (!NILP (host)) + if (NILP (host)) + { + /* The "connection" function gets it bind info from the address we're + given, so use this dummy address if nothing is specified. */ + host = build_string ("127.0.0.1"); + } + else { if (EQ (host, Qlocal)) /* Depending on setup, "localhost" may map to different IPv4 and/or @@ -3810,7 +3816,7 @@ usage: (make-network-process &rest ARGS) */) /* If we're doing async address resolution, the list of addresses here will be nil, so we postpone connecting to the server. */ - if (NILP (ip_addresses)) + if (!p->is_server && NILP (ip_addresses)) { int channel; commit 860303cc4d2b783dfbac75d0ebe2f68703c09946 Author: Lars Ingebrigtsen Date: Sat Jan 30 01:33:30 2016 +0100 Further make_network_process clean up * process.c (Fmake_network_process): Remove setting of unused family variable. diff --git a/src/process.c b/src/process.c index 88441c9..e40d7a4 100644 --- a/src/process.c +++ b/src/process.c @@ -3691,7 +3691,6 @@ usage: (make-network-process &rest ARGS) */) (lres->ai_addr, lres->ai_addrlen), ip_addresses); ai_protocol = lres->ai_protocol; - family = lres->ai_family; } ip_addresses = Fnreverse (ip_addresses); @@ -3743,7 +3742,6 @@ usage: (make-network-process &rest ARGS) */) ip_addresses = Ncons (make_number (host_info_ptr->h_addr, host_info_ptr->h_length), Qnil); - family = host_info_ptr->h_addrtype; } else /* Attempt to interpret host as numeric inet address. */ commit 4876011820930e3f63c5129c432927a4b4600fab Author: Lars Ingebrigtsen Date: Sat Jan 30 01:28:34 2016 +0100 Clean up GETADDRINFO usage in make-network-process * process.c (Fmake_network_process): Clean up the GETADDRINFO handling. diff --git a/src/process.c b/src/process.c index 4f0c4e9..88441c9 100644 --- a/src/process.c +++ b/src/process.c @@ -3471,12 +3471,11 @@ usage: (make-network-process &rest ARGS) */) Lisp_Object proc; Lisp_Object contact; struct Lisp_Process *p; -#ifdef HAVE_GETADDRINFO - struct addrinfo ai, *res, *lres; +#if defined(HAVE_GETADDRINFO) || defined(HAVE_GETADDRINFO_A) struct addrinfo *hints; const char *portstring; char portbuf[128]; -#endif /* HAVE_GETADDRINFO */ +#endif #ifdef HAVE_LOCAL_SOCKETS struct sockaddr_un address_un; #endif @@ -3527,12 +3526,6 @@ usage: (make-network-process &rest ARGS) */) CHECK_STRING (name); - /* Initialize addrinfo structure in case we don't use getaddrinfo. */ - ai.ai_socktype = socktype; - ai.ai_protocol = 0; - ai.ai_next = NULL; - res = &ai; - /* :local ADDRESS or :remote ADDRESS */ tem = Fplist_get (contact, QCserver); if (!NILP (tem)) @@ -3652,6 +3645,7 @@ usage: (make-network-process &rest ARGS) */) { struct gaicb **reqs = xmalloc (sizeof (struct gaicb*)); + printf("Async DNS for '%s'\n", SSDATA (host)); dns_request = xmalloc (sizeof (struct gaicb)); reqs[0] = dns_request; dns_request->ar_name = strdup (SSDATA (host)); @@ -3673,6 +3667,8 @@ usage: (make-network-process &rest ARGS) */) if (!NILP (host)) { + struct addrinfo *res, *lres; + immediate_quit = 1; QUIT; @@ -3699,6 +3695,8 @@ usage: (make-network-process &rest ARGS) */) } ip_addresses = Fnreverse (ip_addresses); + + freeaddrinfo (res); xfree (hints); goto open_socket; commit fdfb68690f75a77a32d286e17a39e2543e07e58c Author: Lars Ingebrigtsen Date: Sat Jan 30 00:49:18 2016 +0100 Implement asynchronous name resolution * process.c (Fmake_network_process): Do asynchronous DNS lookups if we have getaddrinfo_a and the user requests :nowait. (check_for_dns): New function. (wait_reading_process_output): Check for pending name resolution in the idle loop. * process.h: Add structure for async DNS. diff --git a/src/process.c b/src/process.c index b5d306f..4f0c4e9 100644 --- a/src/process.c +++ b/src/process.c @@ -281,6 +281,10 @@ static int max_input_desc; /* Indexed by descriptor, gives the process (if any) for that descriptor. */ static Lisp_Object chan_process[FD_SETSIZE]; +#ifdef HAVE_GETADDRINFO_A +/* Pending DNS requests. */ +static Lisp_Object dns_process[FD_SETSIZE]; +#endif /* Alist of elements (NAME . PROCESS). */ static Lisp_Object Vprocess_alist; @@ -3012,7 +3016,7 @@ void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) Lisp_Object contact = p->childp; int optbits = 0; - /* Do this in case we never enter the for-loop below. */ + /* Do this in case we never enter the while-loop below. */ count1 = SPECPDL_INDEX (); s = -1; @@ -3028,7 +3032,7 @@ void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) addrlen = get_lisp_to_sockaddr_size (ip_address, &family); if (sa) free (sa); - sa = alloca (addrlen); + sa = xmalloc (addrlen); conv_lisp_to_sockaddr (family, ip_address, sa, addrlen); s = socket (family, p->socktype | SOCK_CLOEXEC, p->ai_protocol); @@ -3469,7 +3473,7 @@ usage: (make-network-process &rest ARGS) */) struct Lisp_Process *p; #ifdef HAVE_GETADDRINFO struct addrinfo ai, *res, *lres; - struct addrinfo hints; + struct addrinfo *hints; const char *portstring; char portbuf[128]; #endif /* HAVE_GETADDRINFO */ @@ -3485,6 +3489,9 @@ usage: (make-network-process &rest ARGS) */) int socktype; int family = -1; int ai_protocol = 0; +#ifdef HAVE_GETADDRINFO_A + struct gaicb *dns_request = NULL; +#endif ptrdiff_t count = SPECPDL_INDEX (); if (nargs == 0) @@ -3610,10 +3617,7 @@ usage: (make-network-process &rest ARGS) */) } #endif -#ifdef HAVE_GETADDRINFO - /* If we have a host, use getaddrinfo to resolve both host and service. - Otherwise, use getservbyname to lookup the service. */ - +#if defined (HAVE_GETADDRINFO) || defined (HAVE_GETADDRINFO_A) if (!NILP (host)) { @@ -3632,19 +3636,51 @@ usage: (make-network-process &rest ARGS) */) portstring = SSDATA (service); } + hints = xmalloc (sizeof (struct addrinfo)); + memset (hints, 0, sizeof (struct addrinfo)); + hints->ai_flags = 0; + hints->ai_family = family; + hints->ai_socktype = socktype; + hints->ai_protocol = 0; + } + +#endif + +#ifdef HAVE_GETADDRINFO_A + if (!NILP (Fplist_get (contact, QCnowait)) && + !NILP (host)) + { + struct gaicb **reqs = xmalloc (sizeof (struct gaicb*)); + + dns_request = xmalloc (sizeof (struct gaicb)); + reqs[0] = dns_request; + dns_request->ar_name = strdup (SSDATA (host)); + dns_request->ar_service = strdup (portstring); + dns_request->ar_request = hints; + dns_request->ar_result = NULL; + + ret = getaddrinfo_a (GAI_NOWAIT, reqs, 1, NULL); + if (ret) + error ("%s/%s getaddrinfo_a error %d", SSDATA (host), portstring, ret); + + goto open_socket; + } +#endif /* HAVE_GETADDRINFO_A */ + +#ifdef HAVE_GETADDRINFO + /* If we have a host, use getaddrinfo to resolve both host and service. + Otherwise, use getservbyname to lookup the service. */ + + if (!NILP (host)) + { immediate_quit = 1; QUIT; - memset (&hints, 0, sizeof (hints)); - hints.ai_flags = 0; - hints.ai_family = family; - hints.ai_socktype = socktype; - hints.ai_protocol = 0; #ifdef HAVE_RES_INIT res_init (); #endif - ret = getaddrinfo (SSDATA (host), portstring, &hints, &res); + ret = getaddrinfo (SSDATA (host), portstring, hints, &res); if (ret) #ifdef HAVE_GAI_STRERROR error ("%s/%s %s", SSDATA (host), portstring, gai_strerror (ret)); @@ -3663,6 +3699,7 @@ usage: (make-network-process &rest ARGS) */) } ip_addresses = Fnreverse (ip_addresses); + xfree (hints); goto open_socket; } @@ -3749,6 +3786,7 @@ usage: (make-network-process &rest ARGS) */) p->port = port; p->socktype = socktype; p->ai_protocol = ai_protocol; + p->dns_request = NULL; unbind_to (count, Qnil); @@ -3774,7 +3812,26 @@ usage: (make-network-process &rest ARGS) */) #endif } - connect_network_socket (proc, ip_addresses); + /* If we're doing async address resolution, the list of addresses + here will be nil, so we postpone connecting to the server. */ + if (NILP (ip_addresses)) + { + int channel; + + p->dns_request = dns_request; + p->status = Qconnect; + for (channel = 0; channel < FD_SETSIZE; ++channel) + if (NILP (dns_process[channel])) + { + dns_process[channel] = proc; + break; + } + } + else + { + connect_network_socket (proc, ip_addresses); + } + return proc; } @@ -4479,6 +4536,40 @@ server_accept_connection (Lisp_Object server, int channel) exec_sentinel (proc, concat3 (open_from, host_string, nl)); } +#ifdef HAVE_GETADDRINFO_A +static int +check_for_dns (Lisp_Object proc) +{ + struct Lisp_Process *p = XPROCESS (proc); + Lisp_Object ip_addresses = Qnil; + int ret = 0; + + ret = gai_error (p->dns_request); + if (ret == EAI_INPROGRESS) + return 0; + + /* We got a response. */ + if (ret == 0) + { + struct addrinfo *res; + + for (res = p->dns_request->ar_result; res; res = res->ai_next) + { + ip_addresses = Fcons (conv_sockaddr_to_lisp + (res->ai_addr, res->ai_addrlen), + ip_addresses); + } + + ip_addresses = Fnreverse (ip_addresses); + connect_network_socket (proc, ip_addresses); + return 1; + } + + pset_status (p, Qfailed); + return 0; +} +#endif /* HAVE_GETADDRINFO_A */ + /* This variable is different from waiting_for_input in keyboard.c. It is used to communicate to a lisp process-filter/sentinel (via the function Fwaiting_for_user_input_p below) whether Emacs was waiting @@ -4604,6 +4695,22 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, if (! NILP (wait_for_cell) && ! NILP (XCAR (wait_for_cell))) break; +#ifdef HAVE_GETADDRINFO_A + for (channel = 0; channel < FD_SETSIZE; ++channel) + { + if (! NILP (dns_process[channel])) + { + struct Lisp_Process *p = XPROCESS (dns_process[channel]); + if (p && p->dns_request && + (! wait_proc || p == wait_proc) && + check_for_dns (dns_process[channel])) + { + dns_process[channel] = Qnil; + } + } + } +#endif /* HAVE_GETADDRINFO_A */ + /* Compute time from now till when time limit is up. */ /* Exit if already run out. */ if (wait == TIMEOUT) @@ -7450,6 +7557,9 @@ init_process_emacs (void) { chan_process[i] = Qnil; proc_buffered_char[i] = -1; +#ifdef HAVE_GETADDRINFO_A + dns_process[i] = Qnil; +#endif } memset (proc_decode_coding_system, 0, sizeof proc_decode_coding_system); memset (proc_encode_coding_system, 0, sizeof proc_encode_coding_system); diff --git a/src/process.h b/src/process.h index e2e6ca9..684434c 100644 --- a/src/process.h +++ b/src/process.h @@ -161,14 +161,26 @@ 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_request; +#endif + #ifdef HAVE_GNUTLS gnutls_initstage_t gnutls_initstage; gnutls_session_t gnutls_state; commit 44e235dd88d3f506b31db24373c0f5d5fd27c79d Author: Lars Ingebrigtsen Date: Fri Jan 29 00:36:11 2016 +0100 Fix memory leak * process.c (connect_network_socket): Free previous sockaddr before allocating a new one. diff --git a/src/process.c b/src/process.c index 2f7668a..b5d306f 100644 --- a/src/process.c +++ b/src/process.c @@ -3005,7 +3005,7 @@ void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) int xerrno = 0; Lisp_Object ip_address; int family; - struct sockaddr *sa; + struct sockaddr *sa = NULL; int ret; int addrlen; struct Lisp_Process *p = XPROCESS (proc); @@ -3026,6 +3026,8 @@ void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) #endif addrlen = get_lisp_to_sockaddr_size (ip_address, &family); + if (sa) + free (sa); sa = alloca (addrlen); conv_lisp_to_sockaddr (family, ip_address, sa, addrlen); commit 7c6a60fa2c7f7c8b3f5b2effdda1b3ce9e231071 Author: Lars Ingebrigtsen Date: Fri Jan 29 00:25:07 2016 +0100 Return IP addresses in the correct order * src/process.c (Fmake_network_process): Return the IP addresses in the same order as getaddrinfo does. (set_network_socket_coding_system): Clean up the code slightly. diff --git a/src/process.c b/src/process.c index 1329d96..2f7668a 100644 --- a/src/process.c +++ b/src/process.c @@ -2904,11 +2904,14 @@ usage: (make-serial-process &rest ARGS) */) return proc; } -void set_network_socket_coding_system (Lisp_Object proc) { +void set_network_socket_coding_system (Lisp_Object proc) +{ Lisp_Object tem; struct Lisp_Process *p = XPROCESS (proc); Lisp_Object contact = p->childp; Lisp_Object service, host, name; + Lisp_Object coding_systems = Qt; + Lisp_Object val; service = Fplist_get (contact, QCservice); host = Fplist_get (contact, QChost); @@ -2918,75 +2921,72 @@ void set_network_socket_coding_system (Lisp_Object proc) { if (!NILP (tem) && (!CONSP (tem) || !CONSP (XCDR (tem)))) tem = Qnil; /* No error message (too late!). */ - { - /* Setup coding systems for communicating with the network stream. */ - /* Qt denotes we have not yet called Ffind_operation_coding_system. */ - Lisp_Object coding_systems = Qt; - Lisp_Object val; + /* Setup coding systems for communicating with the network stream. */ + /* Qt denotes we have not yet called Ffind_operation_coding_system. */ - if (!NILP (tem)) - { - val = XCAR (XCDR (tem)); - if (CONSP (val)) - val = XCAR (val); - } - else if (!NILP (Vcoding_system_for_read)) - val = Vcoding_system_for_read; - else if ((!NILP (p->buffer) && - NILP (BVAR (XBUFFER (p->buffer), enable_multibyte_characters))) - || (NILP (p->buffer) && NILP (BVAR (&buffer_defaults, enable_multibyte_characters)))) - /* We dare not decode end-of-line format by setting VAL to - Qraw_text, because the existing Emacs Lisp libraries - assume that they receive bare code including a sequence of - CR LF. */ - val = Qnil; - else - { - if (NILP (host) || NILP (service)) - coding_systems = Qnil; - else - coding_systems = CALLN (Ffind_operation_coding_system, - Qopen_network_stream, name, p->buffer, - host, service); - if (CONSP (coding_systems)) - val = XCAR (coding_systems); - else if (CONSP (Vdefault_process_coding_system)) - val = XCAR (Vdefault_process_coding_system); - else - val = Qnil; - } - pset_decode_coding_system (p, val); + if (!NILP (tem)) + { + val = XCAR (XCDR (tem)); + if (CONSP (val)) + val = XCAR (val); + } + else if (!NILP (Vcoding_system_for_read)) + val = Vcoding_system_for_read; + else if ((!NILP (p->buffer) && + NILP (BVAR (XBUFFER (p->buffer), enable_multibyte_characters))) + || (NILP (p->buffer) && NILP (BVAR (&buffer_defaults, enable_multibyte_characters)))) + /* We dare not decode end-of-line format by setting VAL to + Qraw_text, because the existing Emacs Lisp libraries + assume that they receive bare code including a sequence of + CR LF. */ + val = Qnil; + else + { + if (NILP (host) || NILP (service)) + coding_systems = Qnil; + else + coding_systems = CALLN (Ffind_operation_coding_system, + Qopen_network_stream, name, p->buffer, + host, service); + if (CONSP (coding_systems)) + val = XCAR (coding_systems); + else if (CONSP (Vdefault_process_coding_system)) + val = XCAR (Vdefault_process_coding_system); + else + val = Qnil; + } + pset_decode_coding_system (p, val); + + if (!NILP (tem)) + { + val = XCAR (XCDR (tem)); + if (CONSP (val)) + val = XCDR (val); + } + else if (!NILP (Vcoding_system_for_write)) + val = Vcoding_system_for_write; + else if (NILP (BVAR (current_buffer, enable_multibyte_characters))) + val = Qnil; + else + { + if (EQ (coding_systems, Qt)) + { + if (NILP (host) || NILP (service)) + coding_systems = Qnil; + else + coding_systems = CALLN (Ffind_operation_coding_system, + Qopen_network_stream, name, p->buffer, + host, service); + } + if (CONSP (coding_systems)) + val = XCDR (coding_systems); + else if (CONSP (Vdefault_process_coding_system)) + val = XCDR (Vdefault_process_coding_system); + else + val = Qnil; + } + pset_encode_coding_system (p, val); - if (!NILP (tem)) - { - val = XCAR (XCDR (tem)); - if (CONSP (val)) - val = XCDR (val); - } - else if (!NILP (Vcoding_system_for_write)) - val = Vcoding_system_for_write; - else if (NILP (BVAR (current_buffer, enable_multibyte_characters))) - val = Qnil; - else - { - if (EQ (coding_systems, Qt)) - { - if (NILP (host) || NILP (service)) - coding_systems = Qnil; - else - coding_systems = CALLN (Ffind_operation_coding_system, - Qopen_network_stream, name, p->buffer, - host, service); - } - if (CONSP (coding_systems)) - val = XCDR (coding_systems); - else if (CONSP (Vdefault_process_coding_system)) - val = XCDR (Vdefault_process_coding_system); - else - val = Qnil; - } - pset_encode_coding_system (p, val); - } setup_process_coding_systems (proc); pset_decoding_buf (p, empty_unibyte_string); @@ -2997,7 +2997,8 @@ void set_network_socket_coding_system (Lisp_Object proc) { = !(!NILP (tem) || NILP (p->buffer) || !inherit_process_coding_system); } -void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) { +void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) +{ ptrdiff_t count = SPECPDL_INDEX (); ptrdiff_t count1; int s = -1, outch, inch; @@ -3659,6 +3660,8 @@ usage: (make-network-process &rest ARGS) */) family = lres->ai_family; } + ip_addresses = Fnreverse (ip_addresses); + goto open_socket; } #endif /* HAVE_GETADDRINFO */ commit b013e6a90c0d5f734f37ffafdc848ab94e92380d Author: Lars Ingebrigtsen Date: Thu Jan 28 23:51:55 2016 +0100 Add checks for getaddrinfo_a * configure.ac: Detect getaddrinfo_a. diff --git a/configure.ac b/configure.ac index d3b5183..b00cc1a 100644 --- a/configure.ac +++ b/configure.ac @@ -2408,6 +2408,15 @@ if test "${HAVE_X11}" = "yes" || test "${HAVE_NS}" = "yes" || test "${HAVE_W32}" fi fi +GETADDRINFO_A_LIBS="-lanl" +AC_CHECK_LIB(anl, getaddrinfo_a, HAVE_GETADDRINFO_A=yes, HAVE_GETADDRINFO_A=no, + [$GETADDRINFO_A_LIBS]) +AC_SUBST(GETADDRINFO_A_LIBS) + +OLD_LIBS=$LIBS +LIBS="-lanl $LIBS" +AC_CHECK_FUNCS(getaddrinfo_a) +LIBS=$OLD_LIBS HAVE_GTK=no GTK_OBJ= diff --git a/src/Makefile.in b/src/Makefile.in index defce62..233ed19 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -229,6 +229,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 @@ -473,7 +475,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) commit e09c0972c350e9411683b509414fc598cbf387d3 Author: Lars Ingebrigtsen Date: Thu Jan 28 23:50:47 2016 +0100 Refactor make_network_process * src/process.c (set_network_socket_coding_system) (connect_network_socket): Refactor out of make_network_process to allow calling connect_network_socket asynchronously. (Fmake_network_process): Do nothing but parsing the parameters and name resolution, leaving the connection to connect_network_socket. diff --git a/src/process.c b/src/process.c index e1ebdff..1329d96 100644 --- a/src/process.c +++ b/src/process.c @@ -2904,6 +2904,403 @@ usage: (make-serial-process &rest ARGS) */) return proc; } +void set_network_socket_coding_system (Lisp_Object proc) { + Lisp_Object tem; + struct Lisp_Process *p = XPROCESS (proc); + Lisp_Object contact = p->childp; + Lisp_Object service, host, name; + + service = Fplist_get (contact, QCservice); + host = Fplist_get (contact, QChost); + name = Fplist_get (contact, QCname); + + tem = Fplist_member (contact, QCcoding); + if (!NILP (tem) && (!CONSP (tem) || !CONSP (XCDR (tem)))) + tem = Qnil; /* No error message (too late!). */ + + { + /* Setup coding systems for communicating with the network stream. */ + /* Qt denotes we have not yet called Ffind_operation_coding_system. */ + Lisp_Object coding_systems = Qt; + Lisp_Object val; + + if (!NILP (tem)) + { + val = XCAR (XCDR (tem)); + if (CONSP (val)) + val = XCAR (val); + } + else if (!NILP (Vcoding_system_for_read)) + val = Vcoding_system_for_read; + else if ((!NILP (p->buffer) && + NILP (BVAR (XBUFFER (p->buffer), enable_multibyte_characters))) + || (NILP (p->buffer) && NILP (BVAR (&buffer_defaults, enable_multibyte_characters)))) + /* We dare not decode end-of-line format by setting VAL to + Qraw_text, because the existing Emacs Lisp libraries + assume that they receive bare code including a sequence of + CR LF. */ + val = Qnil; + else + { + if (NILP (host) || NILP (service)) + coding_systems = Qnil; + else + coding_systems = CALLN (Ffind_operation_coding_system, + Qopen_network_stream, name, p->buffer, + host, service); + if (CONSP (coding_systems)) + val = XCAR (coding_systems); + else if (CONSP (Vdefault_process_coding_system)) + val = XCAR (Vdefault_process_coding_system); + else + val = Qnil; + } + pset_decode_coding_system (p, val); + + if (!NILP (tem)) + { + val = XCAR (XCDR (tem)); + if (CONSP (val)) + val = XCDR (val); + } + else if (!NILP (Vcoding_system_for_write)) + val = Vcoding_system_for_write; + else if (NILP (BVAR (current_buffer, enable_multibyte_characters))) + val = Qnil; + else + { + if (EQ (coding_systems, Qt)) + { + if (NILP (host) || NILP (service)) + coding_systems = Qnil; + else + coding_systems = CALLN (Ffind_operation_coding_system, + Qopen_network_stream, name, p->buffer, + host, service); + } + if (CONSP (coding_systems)) + val = XCDR (coding_systems); + else if (CONSP (Vdefault_process_coding_system)) + val = XCDR (Vdefault_process_coding_system); + else + val = Qnil; + } + pset_encode_coding_system (p, val); + } + setup_process_coding_systems (proc); + + pset_decoding_buf (p, empty_unibyte_string); + p->decoding_carryover = 0; + pset_encoding_buf (p, empty_unibyte_string); + + p->inherit_coding_system_flag + = !(!NILP (tem) || NILP (p->buffer) || !inherit_process_coding_system); +} + +void connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses) { + ptrdiff_t count = SPECPDL_INDEX (); + ptrdiff_t count1; + int s = -1, outch, inch; + int xerrno = 0; + Lisp_Object ip_address; + int family; + struct sockaddr *sa; + int ret; + int addrlen; + struct Lisp_Process *p = XPROCESS (proc); + Lisp_Object contact = p->childp; + int optbits = 0; + + /* Do this in case we never enter the for-loop below. */ + count1 = SPECPDL_INDEX (); + s = -1; + + while (!NILP (ip_addresses)) + { + ip_address = Fcar (ip_addresses); + ip_addresses = Fcdr (ip_addresses); + +#ifdef WINDOWSNT + retry_connect: +#endif + + addrlen = get_lisp_to_sockaddr_size (ip_address, &family); + sa = alloca (addrlen); + conv_lisp_to_sockaddr (family, ip_address, sa, addrlen); + + s = socket (family, p->socktype | SOCK_CLOEXEC, p->ai_protocol); + if (s < 0) + { + xerrno = errno; + continue; + } + +#ifdef DATAGRAM_SOCKETS + if (!p->is_server && p->socktype == SOCK_DGRAM) + break; +#endif /* DATAGRAM_SOCKETS */ + +#ifdef NON_BLOCKING_CONNECT + if (p->is_non_blocking_client) + { + ret = fcntl (s, F_SETFL, O_NONBLOCK); + if (ret < 0) + { + xerrno = errno; + emacs_close (s); + s = -1; + continue; + } + } +#endif + + /* Make us close S if quit. */ + record_unwind_protect_int (close_file_unwind, s); + + /* Parse network options in the arg list. We simply ignore anything + which isn't a known option (including other keywords). An error + is signaled if setting a known option fails. */ + { + Lisp_Object params = contact, key, val; + + while (!NILP (params)) { + key = Fcar (params); + params = Fcdr (params); + val = Fcar (params); + params = Fcdr (params); + optbits |= set_socket_option (s, key, val); + } + } + + if (p->is_server) + { + /* Configure as a server socket. */ + + /* SO_REUSEADDR = 1 is default for server sockets; must specify + explicit :reuseaddr key to override this. */ +#ifdef HAVE_LOCAL_SOCKETS + if (family != AF_LOCAL) +#endif + if (!(optbits & (1 << OPIX_REUSEADDR))) + { + int optval = 1; + if (setsockopt (s, SOL_SOCKET, SO_REUSEADDR, &optval, sizeof optval)) + report_file_error ("Cannot set reuse option on server socket", Qnil); + } + + if (bind (s, sa, addrlen)) + report_file_error ("Cannot bind server socket", Qnil); + +#ifdef HAVE_GETSOCKNAME + if (p->port == 0) + { + struct sockaddr_in sa1; + socklen_t len1 = sizeof (sa1); + if (getsockname (s, (struct sockaddr *)&sa1, &len1) == 0) + { + Lisp_Object service; + service = make_number (ntohs (sa1.sin_port)); + contact = Fplist_put (contact, QCservice, service); + } + } +#endif + + if (p->socktype != SOCK_DGRAM && listen (s, p->backlog)) + report_file_error ("Cannot listen on server socket", Qnil); + + break; + } + + immediate_quit = 1; + QUIT; + + ret = connect (s, sa, addrlen); + xerrno = errno; + + if (ret == 0 || xerrno == EISCONN) + { + /* The unwind-protect will be discarded afterwards. + Likewise for immediate_quit. */ + break; + } + +#ifdef NON_BLOCKING_CONNECT +#ifdef EINPROGRESS + if (p->is_non_blocking_client && xerrno == EINPROGRESS) + break; +#else +#ifdef EWOULDBLOCK + if (p->is_non_blocking_client && xerrno == EWOULDBLOCK) + break; +#endif +#endif +#endif + +#ifndef WINDOWSNT + if (xerrno == EINTR) + { + /* Unlike most other syscalls connect() cannot be called + again. (That would return EALREADY.) The proper way to + wait for completion is pselect(). */ + int sc; + socklen_t len; + fd_set fdset; + retry_select: + FD_ZERO (&fdset); + FD_SET (s, &fdset); + QUIT; + sc = pselect (s + 1, NULL, &fdset, NULL, NULL, NULL); + if (sc == -1) + { + if (errno == EINTR) + goto retry_select; + else + report_file_error ("Failed select", Qnil); + } + eassert (sc > 0); + + len = sizeof xerrno; + eassert (FD_ISSET (s, &fdset)); + if (getsockopt (s, SOL_SOCKET, SO_ERROR, &xerrno, &len) < 0) + report_file_error ("Failed getsockopt", Qnil); + if (xerrno) + report_file_errno ("Failed connect", Qnil, xerrno); + break; + } +#endif /* !WINDOWSNT */ + + immediate_quit = 0; + + /* Discard the unwind protect closing S. */ + specpdl_ptr = specpdl + count1; + emacs_close (s); + s = -1; + +#ifdef WINDOWSNT + if (xerrno == EINTR) + goto retry_connect; +#endif + } + + if (s >= 0) + { +#ifdef DATAGRAM_SOCKETS + if (p->socktype == SOCK_DGRAM) + { + if (datagram_address[s].sa) + emacs_abort (); + + datagram_address[s].sa = xmalloc (addrlen); + datagram_address[s].len = addrlen; + if (p->is_server) + { + Lisp_Object remote; + memset (datagram_address[s].sa, 0, addrlen); + if (remote = Fplist_get (contact, QCremote), !NILP (remote)) + { + int rfamily, rlen; + rlen = get_lisp_to_sockaddr_size (remote, &rfamily); + if (rlen != 0 && rfamily == family + && rlen == addrlen) + conv_lisp_to_sockaddr (rfamily, remote, + datagram_address[s].sa, rlen); + } + } + else + memcpy (datagram_address[s].sa, sa, addrlen); + } +#endif + + contact = Fplist_put (contact, p->is_server? QCremote: QClocal, + conv_sockaddr_to_lisp (sa, addrlen)); +#ifdef HAVE_GETSOCKNAME + if (!p->is_server) + { + struct sockaddr_in sa1; + socklen_t len1 = sizeof (sa1); + if (getsockname (s, (struct sockaddr *)&sa1, &len1) == 0) + contact = Fplist_put (contact, QClocal, + conv_sockaddr_to_lisp ((struct sockaddr *)&sa1, len1)); + } +#endif + } + + immediate_quit = 0; + + if (s < 0) + { + /* If non-blocking got this far - and failed - assume non-blocking is + not supported after all. This is probably a wrong assumption, but + the normal blocking calls to open-network-stream handles this error + better. */ + if (p->is_non_blocking_client) + return; + + report_file_errno ((p->is_server + ? "make server process failed" + : "make client process failed"), + contact, xerrno); + } + + inch = s; + outch = s; + + chan_process[inch] = proc; + + fcntl (inch, F_SETFL, O_NONBLOCK); + + p = XPROCESS (proc); + p->open_fd[SUBPROCESS_STDIN] = inch; + p->infd = inch; + p->outfd = outch; + + /* Discard the unwind protect for closing S, if any. */ + specpdl_ptr = specpdl + count1; + + /* Unwind bind_polling_period and request_sigio. */ + unbind_to (count, Qnil); + + if (p->is_server && p->socktype != SOCK_DGRAM) + pset_status (p, Qlisten); + + /* Make the process marker point into the process buffer (if any). */ + if (BUFFERP (p->buffer)) + set_marker_both (p->mark, p->buffer, + BUF_ZV (XBUFFER (p->buffer)), + BUF_ZV_BYTE (XBUFFER (p->buffer))); + +#ifdef NON_BLOCKING_CONNECT + if (p->is_non_blocking_client) + { + /* We may get here if connect did succeed immediately. However, + in that case, we still need to signal this like a non-blocking + connection. */ + pset_status (p, Qconnect); + if (!FD_ISSET (inch, &connect_wait_mask)) + { + FD_SET (inch, &connect_wait_mask); + FD_SET (inch, &write_mask); + num_pending_connects++; + } + } + else +#endif + /* A server may have a client filter setting of Qt, but it must + still listen for incoming connects unless it is stopped. */ + if ((!EQ (p->filter, Qt) && !EQ (p->command, Qt)) + || (EQ (p->status, Qlisten) && NILP (p->command))) + { + FD_SET (inch, &input_wait_mask); + FD_SET (inch, &non_keyboard_wait_mask); + } + + if (inch > max_process_desc) + max_process_desc = inch; + + set_network_socket_coding_system (proc); +} + + /* Create a network stream/datagram client/server process. Treated exactly like a normal process when reading and writing. Primary differences are in status display and process deletion. A network @@ -3072,36 +3469,20 @@ usage: (make-network-process &rest ARGS) */) struct addrinfo hints; const char *portstring; char portbuf[128]; -#else /* HAVE_GETADDRINFO */ - struct _emacs_addrinfo - { - int ai_family; - int ai_socktype; - int ai_protocol; - int ai_addrlen; - struct sockaddr *ai_addr; - struct _emacs_addrinfo *ai_next; - } ai, *res, *lres; #endif /* HAVE_GETADDRINFO */ - struct sockaddr_in address_in; #ifdef HAVE_LOCAL_SOCKETS struct sockaddr_un address_un; #endif - int port; + int port = 0; int ret = 0; - int xerrno = 0; - int s = -1, outch, inch; - ptrdiff_t count = SPECPDL_INDEX (); - ptrdiff_t count1; - Lisp_Object colon_address; /* Either QClocal or QCremote. */ Lisp_Object tem; Lisp_Object name, buffer, host, service, address; Lisp_Object filter, sentinel; - bool is_non_blocking_client = 0; - bool is_server = 0; - int backlog = 5; + Lisp_Object ip_addresses = Qnil; int socktype; int family = -1; + int ai_protocol = 0; + ptrdiff_t count = SPECPDL_INDEX (); if (nargs == 0) return Qnil; @@ -3129,31 +3510,6 @@ usage: (make-network-process &rest ARGS) */) else error ("Unsupported connection type"); - /* :server BOOL */ - tem = Fplist_get (contact, QCserver); - if (!NILP (tem)) - { - /* Don't support network sockets when non-blocking mode is - not available, since a blocked Emacs is not useful. */ - is_server = 1; - if (TYPE_RANGED_INTEGERP (int, tem)) - backlog = XINT (tem); - } - - /* Make colon_address an alias for :local (server) or :remote (client). */ - colon_address = is_server ? QClocal : QCremote; - - /* :nowait BOOL */ - if (!is_server && socktype != SOCK_DGRAM - && (tem = Fplist_get (contact, QCnowait), !NILP (tem))) - { -#ifndef NON_BLOCKING_CONNECT - error ("Non-blocking connect not supported"); -#else - is_non_blocking_client = 1; -#endif - } - name = Fplist_get (contact, QCname); buffer = Fplist_get (contact, QCbuffer); filter = Fplist_get (contact, QCfilter); @@ -3168,16 +3524,19 @@ usage: (make-network-process &rest ARGS) */) res = &ai; /* :local ADDRESS or :remote ADDRESS */ - address = Fplist_get (contact, colon_address); + tem = Fplist_get (contact, QCserver); + if (!NILP (tem)) + address = Fplist_get (contact, QCremote); + else + address = Fplist_get (contact, QClocal); if (!NILP (address)) { host = service = Qnil; - if (!(ai.ai_addrlen = get_lisp_to_sockaddr_size (address, &family))) + if (!get_lisp_to_sockaddr_size (address, &family)) error ("Malformed :address"); - ai.ai_family = family; - ai.ai_addr = alloca (ai.ai_addrlen); - conv_lisp_to_sockaddr (family, address, ai.ai_addr, ai.ai_addrlen); + + ip_addresses = Fcons (address, Qnil); goto open_socket; } @@ -3206,8 +3565,6 @@ usage: (make-network-process &rest ARGS) */) else error ("Unknown address family"); - ai.ai_family = family; - /* :service SERVICE -- string, integer (port number), or t (random port). */ service = Fplist_get (contact, QCservice); @@ -3232,13 +3589,9 @@ usage: (make-network-process &rest ARGS) */) host = Qnil; } CHECK_STRING (service); - memset (&address_un, 0, sizeof address_un); - address_un.sun_family = AF_LOCAL; if (sizeof address_un.sun_path <= SBYTES (service)) error ("Service name too long"); - lispstpcpy (address_un.sun_path, service); - ai.ai_addr = (struct sockaddr *) &address_un; - ai.ai_addrlen = sizeof address_un; + ip_addresses = Fcons (service, Qnil); goto open_socket; } #endif @@ -3257,6 +3610,7 @@ usage: (make-network-process &rest ARGS) */) #ifdef HAVE_GETADDRINFO /* If we have a host, use getaddrinfo to resolve both host and service. Otherwise, use getservbyname to lookup the service. */ + if (!NILP (host)) { @@ -3270,343 +3624,107 @@ usage: (make-network-process &rest ARGS) */) portstring = portbuf; } else - { - CHECK_STRING (service); - portstring = SSDATA (service); - } - - immediate_quit = 1; - QUIT; - memset (&hints, 0, sizeof (hints)); - hints.ai_flags = 0; - hints.ai_family = family; - hints.ai_socktype = socktype; - hints.ai_protocol = 0; - -#ifdef HAVE_RES_INIT - res_init (); -#endif - - ret = getaddrinfo (SSDATA (host), portstring, &hints, &res); - if (ret) -#ifdef HAVE_GAI_STRERROR - error ("%s/%s %s", SSDATA (host), portstring, gai_strerror (ret)); -#else - error ("%s/%s getaddrinfo error %d", SSDATA (host), portstring, ret); -#endif - immediate_quit = 0; - - goto open_socket; - } -#endif /* HAVE_GETADDRINFO */ - - /* We end up here if getaddrinfo is not defined, or in case no hostname - has been specified (e.g. for a local server process). */ - - if (EQ (service, Qt)) - port = 0; - else if (INTEGERP (service)) - port = htons ((unsigned short) XINT (service)); - else - { - struct servent *svc_info; - CHECK_STRING (service); - svc_info = getservbyname (SSDATA (service), - (socktype == SOCK_DGRAM ? "udp" : "tcp")); - if (svc_info == 0) - error ("Unknown service: %s", SDATA (service)); - port = svc_info->s_port; - } - - memset (&address_in, 0, sizeof address_in); - address_in.sin_family = family; - address_in.sin_addr.s_addr = INADDR_ANY; - address_in.sin_port = port; - -#ifndef HAVE_GETADDRINFO - if (!NILP (host)) - { - struct hostent *host_info_ptr; - - /* gethostbyname may fail with TRY_AGAIN, but we don't honor that, - as it may `hang' Emacs for a very long time. */ - immediate_quit = 1; - QUIT; - -#ifdef HAVE_RES_INIT - res_init (); -#endif - - host_info_ptr = gethostbyname (SDATA (host)); - immediate_quit = 0; - - if (host_info_ptr) - { - memcpy (&address_in.sin_addr, host_info_ptr->h_addr, - host_info_ptr->h_length); - family = host_info_ptr->h_addrtype; - address_in.sin_family = family; - } - else - /* Attempt to interpret host as numeric inet address. */ - { - unsigned long numeric_addr; - numeric_addr = inet_addr (SSDATA (host)); - if (numeric_addr == -1) - error ("Unknown host \"%s\"", SDATA (host)); - - memcpy (&address_in.sin_addr, &numeric_addr, - sizeof (address_in.sin_addr)); - } - - } -#endif /* not HAVE_GETADDRINFO */ - - ai.ai_family = family; - ai.ai_addr = (struct sockaddr *) &address_in; - ai.ai_addrlen = sizeof address_in; - - open_socket: - - /* Do this in case we never enter the for-loop below. */ - count1 = SPECPDL_INDEX (); - s = -1; - - for (lres = res; lres; lres = lres->ai_next) - { - ptrdiff_t optn; - int optbits; - -#ifdef WINDOWSNT - retry_connect: -#endif - - s = socket (lres->ai_family, lres->ai_socktype | SOCK_CLOEXEC, - lres->ai_protocol); - if (s < 0) - { - xerrno = errno; - continue; - } - -#ifdef DATAGRAM_SOCKETS - if (!is_server && socktype == SOCK_DGRAM) - break; -#endif /* DATAGRAM_SOCKETS */ - -#ifdef NON_BLOCKING_CONNECT - if (is_non_blocking_client) - { - ret = fcntl (s, F_SETFL, O_NONBLOCK); - if (ret < 0) - { - xerrno = errno; - emacs_close (s); - s = -1; - continue; - } - } -#endif - - /* Make us close S if quit. */ - record_unwind_protect_int (close_file_unwind, s); - - /* Parse network options in the arg list. - We simply ignore anything which isn't a known option (including other keywords). - An error is signaled if setting a known option fails. */ - for (optn = optbits = 0; optn < nargs - 1; optn += 2) - optbits |= set_socket_option (s, args[optn], args[optn + 1]); - - if (is_server) - { - /* Configure as a server socket. */ - - /* SO_REUSEADDR = 1 is default for server sockets; must specify - explicit :reuseaddr key to override this. */ -#ifdef HAVE_LOCAL_SOCKETS - if (family != AF_LOCAL) -#endif - if (!(optbits & (1 << OPIX_REUSEADDR))) - { - int optval = 1; - if (setsockopt (s, SOL_SOCKET, SO_REUSEADDR, &optval, sizeof optval)) - report_file_error ("Cannot set reuse option on server socket", Qnil); - } - - if (bind (s, lres->ai_addr, lres->ai_addrlen)) - report_file_error ("Cannot bind server socket", Qnil); - -#ifdef HAVE_GETSOCKNAME - if (EQ (service, Qt)) - { - struct sockaddr_in sa1; - socklen_t len1 = sizeof (sa1); - if (getsockname (s, (struct sockaddr *)&sa1, &len1) == 0) - { - ((struct sockaddr_in *)(lres->ai_addr))->sin_port = sa1.sin_port; - service = make_number (ntohs (sa1.sin_port)); - contact = Fplist_put (contact, QCservice, service); - } - } -#endif - - if (socktype != SOCK_DGRAM && listen (s, backlog)) - report_file_error ("Cannot listen on server socket", Qnil); - - break; - } - - immediate_quit = 1; - QUIT; - - ret = connect (s, lres->ai_addr, lres->ai_addrlen); - xerrno = errno; - - if (ret == 0 || xerrno == EISCONN) - { - /* The unwind-protect will be discarded afterwards. - Likewise for immediate_quit. */ - break; - } - -#ifdef NON_BLOCKING_CONNECT -#ifdef EINPROGRESS - if (is_non_blocking_client && xerrno == EINPROGRESS) - break; -#else -#ifdef EWOULDBLOCK - if (is_non_blocking_client && xerrno == EWOULDBLOCK) - break; -#endif -#endif -#endif - -#ifndef WINDOWSNT - if (xerrno == EINTR) - { - /* Unlike most other syscalls connect() cannot be called - again. (That would return EALREADY.) The proper way to - wait for completion is pselect(). */ - int sc; - socklen_t len; - fd_set fdset; - retry_select: - FD_ZERO (&fdset); - FD_SET (s, &fdset); - QUIT; - sc = pselect (s + 1, NULL, &fdset, NULL, NULL, NULL); - if (sc == -1) - { - if (errno == EINTR) - goto retry_select; - else - report_file_error ("Failed select", Qnil); - } - eassert (sc > 0); - - len = sizeof xerrno; - eassert (FD_ISSET (s, &fdset)); - if (getsockopt (s, SOL_SOCKET, SO_ERROR, &xerrno, &len) < 0) - report_file_error ("Failed getsockopt", Qnil); - if (xerrno) - report_file_errno ("Failed connect", Qnil, xerrno); - break; + { + CHECK_STRING (service); + portstring = SSDATA (service); } -#endif /* !WINDOWSNT */ - immediate_quit = 0; - - /* Discard the unwind protect closing S. */ - specpdl_ptr = specpdl + count1; - emacs_close (s); - s = -1; + immediate_quit = 1; + QUIT; + memset (&hints, 0, sizeof (hints)); + hints.ai_flags = 0; + hints.ai_family = family; + hints.ai_socktype = socktype; + hints.ai_protocol = 0; -#ifdef WINDOWSNT - if (xerrno == EINTR) - goto retry_connect; +#ifdef HAVE_RES_INIT + res_init (); #endif - } - if (s >= 0) - { -#ifdef DATAGRAM_SOCKETS - if (socktype == SOCK_DGRAM) - { - if (datagram_address[s].sa) - emacs_abort (); - datagram_address[s].sa = xmalloc (lres->ai_addrlen); - datagram_address[s].len = lres->ai_addrlen; - if (is_server) - { - Lisp_Object remote; - memset (datagram_address[s].sa, 0, lres->ai_addrlen); - if (remote = Fplist_get (contact, QCremote), !NILP (remote)) - { - int rfamily, rlen; - rlen = get_lisp_to_sockaddr_size (remote, &rfamily); - if (rlen != 0 && rfamily == lres->ai_family - && rlen == lres->ai_addrlen) - conv_lisp_to_sockaddr (rfamily, remote, - datagram_address[s].sa, rlen); - } - } - else - memcpy (datagram_address[s].sa, lres->ai_addr, lres->ai_addrlen); - } + ret = getaddrinfo (SSDATA (host), portstring, &hints, &res); + if (ret) +#ifdef HAVE_GAI_STRERROR + error ("%s/%s %s", SSDATA (host), portstring, gai_strerror (ret)); +#else + error ("%s/%s getaddrinfo error %d", SSDATA (host), portstring, ret); #endif - contact = Fplist_put (contact, colon_address, - conv_sockaddr_to_lisp (lres->ai_addr, lres->ai_addrlen)); -#ifdef HAVE_GETSOCKNAME - if (!is_server) + immediate_quit = 0; + + for (lres = res; lres; lres = lres->ai_next) { - struct sockaddr_in sa1; - socklen_t len1 = sizeof (sa1); - if (getsockname (s, (struct sockaddr *)&sa1, &len1) == 0) - contact = Fplist_put (contact, QClocal, - conv_sockaddr_to_lisp ((struct sockaddr *)&sa1, len1)); + ip_addresses = Fcons (conv_sockaddr_to_lisp + (lres->ai_addr, lres->ai_addrlen), + ip_addresses); + ai_protocol = lres->ai_protocol; + family = lres->ai_family; } -#endif + + goto open_socket; } +#endif /* HAVE_GETADDRINFO */ - immediate_quit = 0; + /* We end up here if getaddrinfo is not defined, or in case no hostname + has been specified (e.g. for a local server process). */ -#ifdef HAVE_GETADDRINFO - if (res != &ai) + if (EQ (service, Qt)) + port = 0; + else if (INTEGERP (service)) + port = htons ((unsigned short) XINT (service)); + else { - block_input (); - freeaddrinfo (res); - unblock_input (); + struct servent *svc_info; + CHECK_STRING (service); + svc_info = getservbyname (SSDATA (service), + (socktype == SOCK_DGRAM ? "udp" : "tcp")); + if (svc_info == 0) + error ("Unknown service: %s", SDATA (service)); + port = svc_info->s_port; } -#endif - if (s < 0) +#ifndef HAVE_GETADDRINFO + if (!NILP (host)) { - /* If non-blocking got this far - and failed - assume non-blocking is - not supported after all. This is probably a wrong assumption, but - the normal blocking calls to open-network-stream handles this error - better. */ - if (is_non_blocking_client) - return Qnil; + struct hostent *host_info_ptr; + + /* gethostbyname may fail with TRY_AGAIN, but we don't honor that, + as it may `hang' Emacs for a very long time. */ + immediate_quit = 1; + QUIT; + +#ifdef HAVE_RES_INIT + res_init (); +#endif + + host_info_ptr = gethostbyname (SDATA (host)); + immediate_quit = 0; + + if (host_info_ptr) + { + ip_addresses = Ncons (make_number (host_info_ptr->h_addr, + host_info_ptr->h_length), + Qnil); + family = host_info_ptr->h_addrtype; + } + else + /* Attempt to interpret host as numeric inet address. */ + { + unsigned long numeric_addr; + numeric_addr = inet_addr (SSDATA (host)); + if (numeric_addr == -1) + error ("Unknown host \"%s\"", SDATA (host)); + + ip_addresses = Ncons (make_number (numeric_addr), Qnil); + } - report_file_errno ((is_server - ? "make server process failed" - : "make client process failed"), - contact, xerrno); } +#endif /* not HAVE_GETADDRINFO */ - inch = s; - outch = s; + open_socket: if (!NILP (buffer)) buffer = Fget_buffer_create (buffer); proc = make_process (name); - - chan_process[inch] = proc; - - fcntl (inch, F_SETFL, O_NONBLOCK); - p = XPROCESS (proc); - pset_childp (p, contact); pset_plist (p, Fcopy_sequence (Fplist_get (contact, QCplist))); pset_type (p, Qnetwork); @@ -3620,135 +3738,38 @@ usage: (make-network-process &rest ARGS) */) if ((tem = Fplist_get (contact, QCstop), !NILP (tem))) pset_command (p, Qt); p->pid = 0; + p->backlog = 5; + p->is_non_blocking_client = 0; + p->is_server = 0; + p->port = port; + p->socktype = socktype; + p->ai_protocol = ai_protocol; - p->open_fd[SUBPROCESS_STDIN] = inch; - p->infd = inch; - p->outfd = outch; - - /* Discard the unwind protect for closing S, if any. */ - specpdl_ptr = specpdl + count1; - - /* Unwind bind_polling_period and request_sigio. */ unbind_to (count, Qnil); - if (is_server && socktype != SOCK_DGRAM) - pset_status (p, Qlisten); - - /* Make the process marker point into the process buffer (if any). */ - if (BUFFERP (buffer)) - set_marker_both (p->mark, buffer, - BUF_ZV (XBUFFER (buffer)), - BUF_ZV_BYTE (XBUFFER (buffer))); - -#ifdef NON_BLOCKING_CONNECT - if (is_non_blocking_client) + /* :server BOOL */ + tem = Fplist_get (contact, QCserver); + if (!NILP (tem)) { - /* We may get here if connect did succeed immediately. However, - in that case, we still need to signal this like a non-blocking - connection. */ - pset_status (p, Qconnect); - if (!FD_ISSET (inch, &connect_wait_mask)) - { - FD_SET (inch, &connect_wait_mask); - FD_SET (inch, &write_mask); - num_pending_connects++; - } + /* Don't support network sockets when non-blocking mode is + not available, since a blocked Emacs is not useful. */ + p->is_server = 1; + if (TYPE_RANGED_INTEGERP (int, tem)) + p->backlog = XINT (tem); } - else -#endif - /* A server may have a client filter setting of Qt, but it must - still listen for incoming connects unless it is stopped. */ - if ((!EQ (p->filter, Qt) && !EQ (p->command, Qt)) - || (EQ (p->status, Qlisten) && NILP (p->command))) - { - FD_SET (inch, &input_wait_mask); - FD_SET (inch, &non_keyboard_wait_mask); - } - - if (inch > max_process_desc) - max_process_desc = inch; - - tem = Fplist_member (contact, QCcoding); - if (!NILP (tem) && (!CONSP (tem) || !CONSP (XCDR (tem)))) - tem = Qnil; /* No error message (too late!). */ - - { - /* Setup coding systems for communicating with the network stream. */ - /* Qt denotes we have not yet called Ffind_operation_coding_system. */ - Lisp_Object coding_systems = Qt; - Lisp_Object val; - - if (!NILP (tem)) - { - val = XCAR (XCDR (tem)); - if (CONSP (val)) - val = XCAR (val); - } - else if (!NILP (Vcoding_system_for_read)) - val = Vcoding_system_for_read; - else if ((!NILP (buffer) && NILP (BVAR (XBUFFER (buffer), enable_multibyte_characters))) - || (NILP (buffer) && NILP (BVAR (&buffer_defaults, enable_multibyte_characters)))) - /* We dare not decode end-of-line format by setting VAL to - Qraw_text, because the existing Emacs Lisp libraries - assume that they receive bare code including a sequence of - CR LF. */ - val = Qnil; - else - { - if (NILP (host) || NILP (service)) - coding_systems = Qnil; - else - coding_systems = CALLN (Ffind_operation_coding_system, - Qopen_network_stream, name, buffer, - host, service); - if (CONSP (coding_systems)) - val = XCAR (coding_systems); - else if (CONSP (Vdefault_process_coding_system)) - val = XCAR (Vdefault_process_coding_system); - else - val = Qnil; - } - pset_decode_coding_system (p, val); - - if (!NILP (tem)) - { - val = XCAR (XCDR (tem)); - if (CONSP (val)) - val = XCDR (val); - } - else if (!NILP (Vcoding_system_for_write)) - val = Vcoding_system_for_write; - else if (NILP (BVAR (current_buffer, enable_multibyte_characters))) - val = Qnil; - else - { - if (EQ (coding_systems, Qt)) - { - if (NILP (host) || NILP (service)) - coding_systems = Qnil; - else - coding_systems = CALLN (Ffind_operation_coding_system, - Qopen_network_stream, name, buffer, - host, service); - } - if (CONSP (coding_systems)) - val = XCDR (coding_systems); - else if (CONSP (Vdefault_process_coding_system)) - val = XCDR (Vdefault_process_coding_system); - else - val = Qnil; - } - pset_encode_coding_system (p, val); - } - setup_process_coding_systems (proc); - - pset_decoding_buf (p, empty_unibyte_string); - p->decoding_carryover = 0; - pset_encoding_buf (p, empty_unibyte_string); - p->inherit_coding_system_flag - = !(!NILP (tem) || NILP (buffer) || !inherit_process_coding_system); + /* :nowait BOOL */ + if (!p->is_server && socktype != SOCK_DGRAM + && (tem = Fplist_get (contact, QCnowait), !NILP (tem))) + { +#ifndef NON_BLOCKING_CONNECT + error ("Non-blocking connect not supported"); +#else + p->is_non_blocking_client = 1; +#endif + } + connect_network_socket (proc, ip_addresses); return proc; } diff --git a/src/process.h b/src/process.h index 8d9f8f4..e2e6ca9 100644 --- a/src/process.h +++ b/src/process.h @@ -161,7 +161,13 @@ 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; + bool_bf is_non_blocking_client : 1; + bool_bf is_server : 1; int raw_status; + int backlog; + int port; + int socktype; + int ai_protocol; #ifdef HAVE_GNUTLS gnutls_initstage_t gnutls_initstage;