[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] master f577f59: Fix merge conflicts in network-stream-test
|
From: |
Lars Ingebrigtsen |
|
Subject: |
[Emacs-diffs] master f577f59: Fix merge conflicts in network-stream-tests.el |
|
Date: |
Mon, 22 Feb 2016 04:17:28 +0000 |
branch: master
commit f577f59a5216bc7708bb840f5eac3e82950e81e8
Merge: 5df6e32 0d3c0f6
Author: Lars Ingebrigtsen <address@hidden>
Commit: Lars Ingebrigtsen <address@hidden>
Fix merge conflicts in network-stream-tests.el
---
configure.ac | 7 +
doc/lispref/processes.texi | 29 +-
doc/misc/emacs-gnutls.texi | 12 +-
lisp/net/gnutls.el | 150 ++--
lisp/net/network-stream.el | 66 +-
lisp/url/url-gw.el | 4 +-
src/Makefile.in | 4 +-
src/eval.c | 15 +-
src/gnutls.c | 388 +++++----
src/gnutls.h | 2 +
src/lisp.h | 2 +
src/process.c | 1625 +++++++++++++++++++++------------
src/process.h | 25 +
test/lisp/net/network-stream-tests.el | 64 +-
14 files changed, 1513 insertions(+), 880 deletions(-)
diff --git a/configure.ac b/configure.ac
index 6834473..1cbd297 100644
--- a/configure.ac
+++ b/configure.ac
@@ -2421,6 +2421,13 @@ if test "${HAVE_X11}" = "yes" || test "${HAVE_NS}" =
"yes" || test "${HAVE_W32}"
fi
fi
+AC_CHECK_LIB(anl, getaddrinfo_a, HAVE_GETADDRINFO_A=yes)
+if test "${HAVE_GETADDRINFO_A}" = "yes"; then
+ AC_DEFINE(HAVE_GETADDRINFO_A, 1,
+[Define to 1 if you have getaddrinfo_a for asynchronous DNS resolution.])
+ GETADDRINFO_A_LIBS="-lanl"
+ AC_SUBST(GETADDRINFO_A_LIBS)
+fi
HAVE_GTK=no
GTK_OBJ=
diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi
index f660b15..79cebaa 100644
--- a/doc/lispref/processes.texi
+++ b/doc/lispref/processes.texi
@@ -2415,8 +2415,33 @@ without waiting for the connection to complete. When
the connection
succeeds or fails, Emacs will call the sentinel function, with a
second argument matching @code{"open"} (if successful) or
@code{"failed"}. The default is to block, so that
address@hidden does not return until the connection
-has succeeded or failed.
address@hidden 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
address@hidden:nowait} is may vary. The three elements that may (or may not)
+be done asynchronously are domain name resolution, socket setup, and
+(for TLS connections) TLS negotiation.
+
+Many functions that interact with process objects, (for instance,
address@hidden) 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.
+
address@hidden :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
address@hidden, 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 address@hidden, start the network connection or
diff --git a/doc/misc/emacs-gnutls.texi b/doc/misc/emacs-gnutls.texi
index 1a850c6..115727f 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}.
address@hidden open-gnutls-stream name buffer host service
address@hidden open-gnutls-stream name buffer host service &optional nowait
This function creates a buffer connected to a specific @var{host} and
@var{service} (port number or service name). The parameters and their
syntax are the same as those given to @code{open-network-stream}
@@ -181,6 +181,10 @@ syntax are the same as those given to
@code{open-network-stream}
Manual}). The connection process is called @var{name} (made unique if
necessary). This function returns the connection process.
+The @var{nowait} parameter means that the scoket should be
+asynchronous, and the connection process will be returned to the
+caller before TLS negotiation has happened.
+
@lisp
;; open a HTTPS connection
(open-gnutls-stream "tls" "tls-buffer" "yourserver.com" "https")
@@ -191,6 +195,12 @@ necessary). This function returns the connection process.
@end defun
address@hidden 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 904cb31..0baf2e3 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,9 @@ BUFFER is the buffer (or `buffer-name') to associate with
the process.
Third arg is name of the host to connect to, or its IP address.
Fourth arg SERVICE is name of the service desired, or an integer
specifying a port number to connect to.
+Fifth arg NOWAIT (which is optional) means that the socket should
+be opened asynchronously. The connection process will be
+returned to the caller before TLS negotiation has happened.
Usage example:
@@ -122,9 +125,20 @@ This is a very simple wrapper around `gnutls-negotiate'.
See its
documentation for the specific parameters you can use to open a
GnuTLS connection, including specifying the credential type,
trust and key files, and priority string."
- (gnutls-negotiate :process (open-network-stream name buffer host service)
- :type 'gnutls-x509pki
- :hostname host))
+ (let ((process (open-network-stream
+ name buffer host service
+ :nowait nowait
+ :tls-parameters
+ (and nowait
+ (cons 'gnutls-x509pki
+ (gnutls-boot-parameters
+ :type 'gnutls-x509pki
+ :hostname host))))))
+ (if nowait
+ process
+ (gnutls-negotiate :process process
+ :type 'gnutls-x509pki
+ :hostname host))))
(define-error 'gnutls-error "GnuTLS error")
@@ -140,10 +154,45 @@ trust and key files, and priority string."
&allow-other-keys)
"Negotiate a SSL/TLS connection. Returns proc. Signals gnutls-error.
-Note arguments are passed CL style, :type TYPE instead of just TYPE.
+Note that arguments are passed CL style, :type TYPE instead of just TYPE.
-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'.
@@ -189,62 +238,47 @@ here's a recent version of the list.
It must be omitted, a number, or nil; if omitted or nil it
defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT."
- (let* ((type (or type 'gnutls-x509pki))
- ;; The gnutls library doesn't understand files delivered via
- ;; the special handlers, so ignore all files found via those.
- (file-name-handler-alist nil)
- (trustfiles (or trustfiles (gnutls-trustfiles)))
- (priority-string (or priority-string
- (cond
- ((eq type 'gnutls-anon)
- "NORMAL:+ANON-DH:!ARCFOUR-128")
- ((eq type 'gnutls-x509pki)
- (if gnutls-algorithm-priority
- (upcase gnutls-algorithm-priority)
- "NORMAL")))))
- (verify-error (or verify-error
- ;; this uses the value of `gnutls-verify-error'
- (cond
- ;; if t, pass it on
- ((eq gnutls-verify-error t)
- t)
- ;; if a list, look for hostname matches
- ((listp gnutls-verify-error)
- (apply 'append
- (mapcar
- (lambda (check)
- (when (string-match (nth 0 check)
- hostname)
- (nth 1 check)))
- gnutls-verify-error)))
- ;; else it's nil
- (t nil))))
- (min-prime-bits (or min-prime-bits gnutls-min-prime-bits))
- params ret)
+ (let ((trustfiles (or trustfiles (gnutls-trustfiles)))
+ (priority-string (or priority-string
+ (cond
+ ((eq type 'gnutls-anon)
+ "NORMAL:+ANON-DH:!ARCFOUR-128")
+ ((eq type 'gnutls-x509pki)
+ (if gnutls-algorithm-priority
+ (upcase gnutls-algorithm-priority)
+ "NORMAL")))))
+ (verify-error (or verify-error
+ ;; this uses the value of `gnutls-verify-error'
+ (cond
+ ;; if t, pass it on
+ ((eq gnutls-verify-error t)
+ t)
+ ;; if a list, look for hostname matches
+ ((listp gnutls-verify-error)
+ (apply 'append
+ (mapcar
+ (lambda (check)
+ (when (string-match (nth 0 check)
+ hostname)
+ (nth 1 check)))
+ gnutls-verify-error)))
+ ;; else it's nil
+ (t nil))))
+ (min-prime-bits (or min-prime-bits gnutls-min-prime-bits)))
(when verify-hostname-error
(push :hostname verify-error))
- (setq params `(:priority ,priority-string
- :hostname ,hostname
- :loglevel ,gnutls-log-level
- :min-prime-bits ,min-prime-bits
- :trustfiles ,trustfiles
- :crlfiles ,crlfiles
- :keylist ,keylist
- :verify-flags ,verify-flags
- :verify-error ,verify-error
- :callbacks nil))
-
- (gnutls-message-maybe
- (setq ret (gnutls-boot process type params))
- "boot: %s" params)
-
- (when (gnutls-errorp ret)
- ;; This is a error from the underlying C code.
- (signal 'gnutls-error (list process ret)))
-
- process))
+ `(:priority ,priority-string
+ :hostname ,hostname
+ :loglevel ,gnutls-log-level
+ :min-prime-bits ,min-prime-bits
+ :trustfiles ,trustfiles
+ :crlfiles ,crlfiles
+ :keylist ,keylist
+ :verify-flags ,verify-flags
+ :verify-error ,verify-error
+ :callbacks nil)))
(defun gnutls-trustfiles ()
"Return a list of usable trustfiles."
diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el
index e5557b8..f919efb 100644
--- a/lisp/net/network-stream.el
+++ b/lisp/net/network-stream.el
@@ -136,8 +136,14 @@ non-nil, is used warn the user if the connection isn't
encrypted.
:nogreeting is a boolean that can be used to inhibit waiting for
a greeting from the server.
-:nowait is a boolean that says the connection should be made
-asynchronously, if possible."
+:nowait, if non-nil, says the connection should be made
+asynchronously, if possible.
+
+:tls-parameters is a list that should be supplied if you're
+opening a TLS connection. The first element is the TLS
+type (either `gnutls-x509pki' or `gnutls-anon'), and the
+remaining elements should be a keyword list accepted by
+gnutls-boot (as returned by `gnutls-boot-parameters')."
(unless (featurep 'make-network-process)
(error "Emacs was compiled without networking support"))
(let ((type (plist-get parameters :type))
@@ -150,7 +156,9 @@ asynchronously, if possible."
;; The simplest case: wrapper around `make-network-process'.
(make-network-process :name name :buffer buffer
:host (puny-encode-domain host) :service service
- :nowait (plist-get parameters :nowait))
+ :nowait (plist-get parameters :nowait)
+ :tls-parameters
+ (plist-get parameters :tls-parameters))
(let ((work-buffer (or buffer
(generate-new-buffer " *stream buffer*")))
(fun (cond ((and (eq type 'plain)
@@ -361,32 +369,34 @@ asynchronously, if possible."
(with-current-buffer buffer
(let* ((start (point-max))
(stream
- (funcall (if (gnutls-available-p)
- 'open-gnutls-stream
- 'open-tls-stream)
- name buffer host service))
+ (if (gnutls-available-p)
+ (open-gnutls-stream name buffer host service
+ (plist-get parameters :nowait))
+ (open-tls-stream name buffer host service)))
(eoc (plist-get parameters :end-of-command)))
- ;; Check certificate validity etc.
- (when (and (gnutls-available-p) stream)
- (setq stream (nsm-verify-connection stream host service)))
- (if (null stream)
- (list nil nil nil 'plain)
- ;; If we're using tls.el, we have to delete the output from
- ;; openssl/gnutls-cli.
- (when (and (not (gnutls-available-p))
- eoc)
- (network-stream-get-response stream start eoc)
- (goto-char (point-min))
- (when (re-search-forward eoc nil t)
- (goto-char (match-beginning 0))
- (delete-region (point-min) (line-beginning-position))))
- (let ((capability-command (plist-get parameters :capability-command))
- (eo-capa (or (plist-get parameters :end-of-capability)
- eoc)))
- (list stream
- (network-stream-get-response stream start eoc)
- (network-stream-command stream capability-command eo-capa)
- 'tls))))))
+ (if (plist-get parameters :nowait)
+ (list stream nil nil 'tls)
+ ;; Check certificate validity etc.
+ (when (and (gnutls-available-p) stream)
+ (setq stream (nsm-verify-connection stream host service)))
+ (if (null stream)
+ (list nil nil nil 'plain)
+ ;; If we're using tls.el, we have to delete the output from
+ ;; openssl/gnutls-cli.
+ (when (and (not (gnutls-available-p))
+ eoc)
+ (network-stream-get-response stream start eoc)
+ (goto-char (point-min))
+ (when (re-search-forward eoc nil t)
+ (goto-char (match-beginning 0))
+ (delete-region (point-min) (line-beginning-position))))
+ (let ((capability-command (plist-get parameters :capability-command))
+ (eo-capa (or (plist-get parameters :end-of-capability)
+ eoc)))
+ (list stream
+ (network-stream-get-response stream start eoc)
+ (network-stream-command stream capability-command eo-capa)
+ 'tls)))))))
(defun network-stream-open-shell (name buffer host service parameters)
(require 'format-spec)
diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el
index 460ee0d..d898368 100644
--- a/lisp/url/url-gw.el
+++ b/lisp/url/url-gw.el
@@ -246,8 +246,8 @@ overriding the value of `url-gateway-method'."
:type gw-method
;; Use non-blocking socket if we can.
:nowait (featurep 'make-network-process
- '(:nowait t))))
- (`socks
+ '(:nowait t))))
+ (`socks
(socks-open-network-stream name buffer host service))
(`telnet
(url-open-telnet name buffer host service))
diff --git a/src/Makefile.in b/src/Makefile.in
index a14d36f..99394ac 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -235,6 +235,8 @@ IMAGEMAGICK_CFLAGS= @IMAGEMAGICK_CFLAGS@
LIBXML2_LIBS = @LIBXML2_LIBS@
LIBXML2_CFLAGS = @LIBXML2_CFLAGS@
+GETADDRINFO_A_LIBS = @GETADDRINFO_A_LIBS@
+
LIBZ = @LIBZ@
## system-specific libs for dynamic modules, else empty
@@ -486,7 +488,7 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE)
$(LIBIMAGE) \
$(LIBXML2_LIBS) $(LIBGPM) $(LIBRESOLV) $(LIBS_SYSTEM) $(CAIRO_LIBS) \
$(LIBS_TERMCAP) $(GETLOADAVG_LIBS) $(SETTINGS_LIBS) $(LIBSELINUX_LIBS) \
$(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \
- $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) \
+ $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) \
$(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES)
$(leimdir)/leim-list.el: bootstrap-emacs$(EXEEXT)
diff --git a/src/eval.c b/src/eval.c
index 26104a5..b6bf0e6 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 01a5983..ce4fbf9 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
@@ -528,26 +540,9 @@ emacs_gnutls_read (struct Lisp_Process *proc, char *buf,
ptrdiff_t nbyte)
ssize_t rtnval;
gnutls_session_t state = proc->gnutls_state;
- int log_level = proc->gnutls_log_level;
-
if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
- {
- /* If the handshake count is under the limit, try the handshake
- again and increment the handshake count. This count is kept
- per process (connection), not globally. */
- if (proc->gnutls_handshakes_tried < GNUTLS_EMACS_HANDSHAKES_LIMIT)
- {
- proc->gnutls_handshakes_tried++;
- emacs_gnutls_handshake (proc);
- GNUTLS_LOG2i (5, log_level, "Retried handshake",
- proc->gnutls_handshakes_tried);
- return -1;
- }
+ return -1;
- GNUTLS_LOG (2, log_level, "Giving up on handshake; resetting retries");
- proc->gnutls_handshakes_tried = 0;
- return 0;
- }
rtnval = gnutls_record_recv (state, buf, nbyte);
if (rtnval >= 0)
return rtnval;
@@ -686,6 +681,19 @@ emacs_gnutls_deinit (Lisp_Object proc)
return Qt;
}
+DEFUN ("gnutls-asynchronous-parameters", Fgnutls_asynchronous_parameters,
+ Sgnutls_asynchronous_parameters, 2, 2, 0,
+ doc: /* Mark this process as being a pre-init GnuTLS process.
+The second parameter is the list of parameters to feed to gnutls-boot
+to finish setting up the connection. */)
+ (Lisp_Object proc, Lisp_Object params)
+{
+ CHECK_PROCESS (proc);
+
+ XPROCESS (proc)->gnutls_boot_parameters = params;
+ return Qnil;
+}
+
DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage, Sgnutls_get_initstage,
1, 1, 0,
doc: /* Return the GnuTLS init stage of process PROC.
See also `gnutls-boot'. */)
@@ -1022,7 +1030,7 @@ The return value is a property list with top-level keys
:warnings and
CHECK_PROCESS (proc);
- if (GNUTLS_INITSTAGE (proc) < GNUTLS_STAGE_INIT)
+ if (GNUTLS_INITSTAGE (proc) != GNUTLS_STAGE_READY)
return Qnil;
/* Then collect any warnings already computed by the handshake. */
@@ -1154,6 +1162,162 @@ emacs_gnutls_global_deinit (void)
}
#endif
+/* VARARGS 1 */
+static void
+boot_error (struct Lisp_Process *p, const char *m, ...)
+{
+ va_list ap;
+ va_start (ap, m);
+ if (p->is_non_blocking_client)
+ pset_status (p, list2 (Qfailed, vformat_string (m, ap)));
+ else
+ verror (m, ap);
+}
+
+Lisp_Object
+gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist)
+{
+ int ret;
+ struct Lisp_Process *p = XPROCESS (proc);
+ gnutls_session_t state = p->gnutls_state;
+ unsigned int peer_verification;
+ Lisp_Object warnings;
+ int max_log_level = p->gnutls_log_level;
+ Lisp_Object hostname, verify_error;
+ bool verify_error_all = 0;
+ char *c_hostname;
+
+ if (NILP (proplist))
+ proplist = Fcdr (Fplist_get (p->childp, QCtls_parameters));
+
+ verify_error = Fplist_get (proplist, QCgnutls_bootprop_verify_error);
+ hostname = Fplist_get (proplist, QCgnutls_bootprop_hostname);
+
+ if (EQ (verify_error, Qt))
+ {
+ verify_error_all = 1;
+ }
+ else if (NILP (Flistp (verify_error)))
+ {
+ boot_error (p, "gnutls-boot: invalid :verify_error parameter (not a
list)");
+ return Qnil;
+ }
+
+ if (!STRINGP (hostname))
+ {
+ boot_error (p, "gnutls-boot: invalid :hostname parameter (not a
string)");
+ return Qnil;
+ }
+ c_hostname = SSDATA (hostname);
+
+ /* Now verify the peer, following
+
http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
+ The peer should present at least one certificate in the chain; do a
+ check of the certificate's hostname with
+ gnutls_x509_crt_check_hostname against :hostname. */
+
+ ret = gnutls_certificate_verify_peers2 (state, &peer_verification);
+ if (ret < GNUTLS_E_SUCCESS)
+ return gnutls_make_error (ret);
+
+ XPROCESS (proc)->gnutls_peer_verification = peer_verification;
+
+ warnings = Fplist_get (Fgnutls_peer_status (proc), intern (":warnings"));
+ if (!NILP (warnings))
+ {
+ Lisp_Object tail;
+ for (tail = warnings; CONSP (tail); tail = XCDR (tail))
+ {
+ Lisp_Object warning = XCAR (tail);
+ Lisp_Object message = Fgnutls_peer_status_warning_describe (warning);
+ if (!NILP (message))
+ GNUTLS_LOG2 (1, max_log_level, "verification:", SSDATA (message));
+ }
+ }
+
+ if (peer_verification != 0)
+ {
+ if (verify_error_all
+ || !NILP (Fmember (QCgnutls_bootprop_trustfiles, verify_error)))
+ {
+ emacs_gnutls_deinit (proc);
+ boot_error (p, "Certificate validation failed %s, verification code
%x",
+ c_hostname, peer_verification);
+ return Qnil;
+ }
+ else
+ {
+ GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:",
+ c_hostname);
+ }
+ }
+
+ /* Up to here the process is the same for X.509 certificates and
+ OpenPGP keys. From now on X.509 certificates are assumed. This
+ can be easily extended to work with openpgp keys as well. */
+ if (gnutls_certificate_type_get (state) == GNUTLS_CRT_X509)
+ {
+ gnutls_x509_crt_t gnutls_verify_cert;
+ const gnutls_datum_t *gnutls_verify_cert_list;
+ unsigned int gnutls_verify_cert_list_size;
+
+ ret = gnutls_x509_crt_init (&gnutls_verify_cert);
+ if (ret < GNUTLS_E_SUCCESS)
+ return gnutls_make_error (ret);
+
+ gnutls_verify_cert_list =
+ gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size);
+
+ if (gnutls_verify_cert_list == NULL)
+ {
+ gnutls_x509_crt_deinit (gnutls_verify_cert);
+ emacs_gnutls_deinit (proc);
+ boot_error (p, "No x509 certificate was found\n");
+ return Qnil;
+ }
+
+ /* We only check the first certificate in the given chain. */
+ ret = gnutls_x509_crt_import (gnutls_verify_cert,
+ &gnutls_verify_cert_list[0],
+ GNUTLS_X509_FMT_DER);
+
+ if (ret < GNUTLS_E_SUCCESS)
+ {
+ gnutls_x509_crt_deinit (gnutls_verify_cert);
+ return gnutls_make_error (ret);
+ }
+
+ XPROCESS (proc)->gnutls_certificate = gnutls_verify_cert;
+
+ int err = gnutls_x509_crt_check_hostname (gnutls_verify_cert,
+ c_hostname);
+ check_memory_full (err);
+ if (!err)
+ {
+ XPROCESS (proc)->gnutls_extra_peer_verification |=
+ CERTIFICATE_NOT_MATCHING;
+ if (verify_error_all
+ || !NILP (Fmember (QCgnutls_bootprop_hostname, verify_error)))
+ {
+ gnutls_x509_crt_deinit (gnutls_verify_cert);
+ emacs_gnutls_deinit (proc);
+ boot_error (p, "The x509 certificate does not match \"%s\"",
c_hostname);
+ return Qnil;
+ }
+ else
+ {
+ GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not
match:",
+ c_hostname);
+ }
+ }
+ }
+
+ /* Set this flag only if the whole initialization succeeded. */
+ XPROCESS (proc)->gnutls_p = 1;
+
+ return gnutls_make_error (ret);
+}
+
DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
doc: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
Currently only client mode is supported. Return a success/failure
@@ -1212,14 +1376,12 @@ one trustfile (usually a CA bundle). */)
{
int ret = GNUTLS_E_SUCCESS;
int max_log_level = 0;
- bool verify_error_all = 0;
gnutls_session_t state;
gnutls_certificate_credentials_t x509_cred = NULL;
gnutls_anon_client_credentials_t anon_cred = NULL;
Lisp_Object global_init;
char const *priority_string_ptr = "NORMAL"; /* default priority string. */
- unsigned int peer_verification;
char *c_hostname;
/* Placeholders for the property list elements. */
@@ -1230,19 +1392,24 @@ one trustfile (usually a CA bundle). */)
/* Lisp_Object callbacks; */
Lisp_Object loglevel;
Lisp_Object hostname;
- Lisp_Object verify_error;
Lisp_Object prime_bits;
- Lisp_Object warnings;
+ struct Lisp_Process *p = XPROCESS (proc);
CHECK_PROCESS (proc);
CHECK_SYMBOL (type);
CHECK_LIST (proplist);
if (NILP (Fgnutls_available_p ()))
- error ("GnuTLS not available");
+ {
+ boot_error (p, "GnuTLS not available");
+ return Qnil;
+ }
if (!EQ (type, Qgnutls_x509pki) && !EQ (type, Qgnutls_anon))
- error ("Invalid GnuTLS credential type");
+ {
+ boot_error (p, "Invalid GnuTLS credential type");
+ return Qnil;
+ }
hostname = Fplist_get (proplist, QCgnutls_bootprop_hostname);
priority_string = Fplist_get (proplist, QCgnutls_bootprop_priority);
@@ -1250,20 +1417,13 @@ one trustfile (usually a CA bundle). */)
keylist = Fplist_get (proplist, QCgnutls_bootprop_keylist);
crlfiles = Fplist_get (proplist, QCgnutls_bootprop_crlfiles);
loglevel = Fplist_get (proplist, QCgnutls_bootprop_loglevel);
- verify_error = Fplist_get (proplist,
QCgnutls_bootprop_verify_error);
prime_bits = Fplist_get (proplist,
QCgnutls_bootprop_min_prime_bits);
- if (EQ (verify_error, Qt))
- {
- verify_error_all = 1;
- }
- else if (NILP (Flistp (verify_error)))
+ if (!STRINGP (hostname))
{
- error ("gnutls-boot: invalid :verify_error parameter (not a list)");
+ boot_error (p, "gnutls-boot: invalid :hostname parameter (not a
string)");
+ return Qnil;
}
-
- if (!STRINGP (hostname))
- error ("gnutls-boot: invalid :hostname parameter (not a string)");
c_hostname = SSDATA (hostname);
state = XPROCESS (proc)->gnutls_state;
@@ -1371,7 +1531,8 @@ one trustfile (usually a CA bundle). */)
else
{
emacs_gnutls_deinit (proc);
- error ("Invalid trustfile");
+ boot_error (p, "Invalid trustfile");
+ return Qnil;
}
}
@@ -1395,7 +1556,8 @@ one trustfile (usually a CA bundle). */)
else
{
emacs_gnutls_deinit (proc);
- error ("Invalid CRL file");
+ boot_error (p, "Invalid CRL file");
+ return Qnil;
}
}
@@ -1424,8 +1586,9 @@ one trustfile (usually a CA bundle). */)
else
{
emacs_gnutls_deinit (proc);
- error (STRINGP (keyfile) ? "Invalid client cert file"
- : "Invalid client key file");
+ boot_error (p, STRINGP (keyfile) ? "Invalid client cert file"
+ : "Invalid client key file");
+ return Qnil;
}
}
}
@@ -1484,109 +1647,7 @@ one trustfile (usually a CA bundle). */)
if (ret < GNUTLS_E_SUCCESS)
return gnutls_make_error (ret);
- /* Now verify the peer, following
-
http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
- The peer should present at least one certificate in the chain; do a
- check of the certificate's hostname with
- gnutls_x509_crt_check_hostname against :hostname. */
-
- ret = gnutls_certificate_verify_peers2 (state, &peer_verification);
- if (ret < GNUTLS_E_SUCCESS)
- return gnutls_make_error (ret);
-
- XPROCESS (proc)->gnutls_peer_verification = peer_verification;
-
- warnings = Fplist_get (Fgnutls_peer_status (proc), intern (":warnings"));
- if (!NILP (warnings))
- {
- Lisp_Object tail;
- for (tail = warnings; CONSP (tail); tail = XCDR (tail))
- {
- Lisp_Object warning = XCAR (tail);
- Lisp_Object message = Fgnutls_peer_status_warning_describe (warning);
- if (!NILP (message))
- GNUTLS_LOG2 (1, max_log_level, "verification:", SSDATA (message));
- }
- }
-
- if (peer_verification != 0)
- {
- if (verify_error_all
- || !NILP (Fmember (QCgnutls_bootprop_trustfiles, verify_error)))
- {
- emacs_gnutls_deinit (proc);
- error ("Certificate validation failed %s, verification code %x",
- c_hostname, peer_verification);
- }
- else
- {
- GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:",
- c_hostname);
- }
- }
-
- /* Up to here the process is the same for X.509 certificates and
- OpenPGP keys. From now on X.509 certificates are assumed. This
- can be easily extended to work with openpgp keys as well. */
- if (gnutls_certificate_type_get (state) == GNUTLS_CRT_X509)
- {
- gnutls_x509_crt_t gnutls_verify_cert;
- const gnutls_datum_t *gnutls_verify_cert_list;
- unsigned int gnutls_verify_cert_list_size;
-
- ret = gnutls_x509_crt_init (&gnutls_verify_cert);
- if (ret < GNUTLS_E_SUCCESS)
- return gnutls_make_error (ret);
-
- gnutls_verify_cert_list =
- gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size);
-
- if (gnutls_verify_cert_list == NULL)
- {
- gnutls_x509_crt_deinit (gnutls_verify_cert);
- emacs_gnutls_deinit (proc);
- error ("No x509 certificate was found\n");
- }
-
- /* We only check the first certificate in the given chain. */
- ret = gnutls_x509_crt_import (gnutls_verify_cert,
- &gnutls_verify_cert_list[0],
- GNUTLS_X509_FMT_DER);
-
- if (ret < GNUTLS_E_SUCCESS)
- {
- gnutls_x509_crt_deinit (gnutls_verify_cert);
- return gnutls_make_error (ret);
- }
-
- XPROCESS (proc)->gnutls_certificate = gnutls_verify_cert;
-
- int err = gnutls_x509_crt_check_hostname (gnutls_verify_cert,
- c_hostname);
- check_memory_full (err);
- if (!err)
- {
- XPROCESS (proc)->gnutls_extra_peer_verification |=
- CERTIFICATE_NOT_MATCHING;
- if (verify_error_all
- || !NILP (Fmember (QCgnutls_bootprop_hostname, verify_error)))
- {
- gnutls_x509_crt_deinit (gnutls_verify_cert);
- emacs_gnutls_deinit (proc);
- error ("The x509 certificate does not match \"%s\"", c_hostname);
- }
- else
- {
- GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not
match:",
- c_hostname);
- }
- }
- }
-
- /* Set this flag only if the whole initialization succeeded. */
- XPROCESS (proc)->gnutls_p = 1;
-
- return gnutls_make_error (ret);
+ return gnutls_verify_boot (proc, proplist);
}
DEFUN ("gnutls-bye", Fgnutls_bye,
@@ -1693,6 +1754,7 @@ syms_of_gnutls (void)
make_number (GNUTLS_E_APPLICATION_ERROR_MIN));
defsubr (&Sgnutls_get_initstage);
+ defsubr (&Sgnutls_asynchronous_parameters);
defsubr (&Sgnutls_errorp);
defsubr (&Sgnutls_error_fatalp);
defsubr (&Sgnutls_error_string);
diff --git a/src/gnutls.h b/src/gnutls.h
index 8e879c1..d03332e 100644
--- a/src/gnutls.h
+++ b/src/gnutls.h
@@ -84,6 +84,8 @@ extern void emacs_gnutls_transport_set_errno
(gnutls_session_t state, int err);
#endif
extern Lisp_Object emacs_gnutls_deinit (Lisp_Object);
extern Lisp_Object emacs_gnutls_global_init (void);
+extern int gnutls_try_handshake (struct Lisp_Process *p);
+extern Lisp_Object gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist);
#endif
diff --git a/src/lisp.h b/src/lisp.h
index 8aa2861..18d9864 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -3906,6 +3906,8 @@ extern Lisp_Object unbind_to (ptrdiff_t, Lisp_Object);
extern _Noreturn void error (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2);
extern _Noreturn void verror (const char *, va_list)
ATTRIBUTE_FORMAT_PRINTF (1, 0);
+extern Lisp_Object vformat_string (const char *, va_list)
+ ATTRIBUTE_FORMAT_PRINTF (1, 0);
extern void un_autoload (Lisp_Object);
extern Lisp_Object call_debugger (Lisp_Object arg);
extern void *near_C_stack_top (void);
diff --git a/src/process.c b/src/process.c
index 1eac5e1..c881a20 100644
--- a/src/process.c
+++ b/src/process.c
@@ -281,6 +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];
+static void wait_for_socket_fds (Lisp_Object process, char *name);
/* Alist of elements (NAME . PROCESS). */
static Lisp_Object Vprocess_alist;
@@ -381,11 +382,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;
@@ -711,6 +707,7 @@ make_process (Lisp_Object name)
#ifdef HAVE_GNUTLS
p->gnutls_initstage = GNUTLS_STAGE_EMPTY;
+ p->gnutls_boot_parameters = Qnil;
#endif
/* If name is already in use, modify it until it is unused. */
@@ -742,6 +739,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. */)
@@ -832,6 +846,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))
{
@@ -1008,6 +1030,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.
@@ -1029,6 +1068,7 @@ The string argument is normally a multibyte string,
except:
struct Lisp_Process *p;
CHECK_PROCESS (process);
+
p = XPROCESS (process);
/* Don't signal an error if the process's input file descriptor
@@ -1042,23 +1082,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);
@@ -1117,7 +1145,8 @@ DEFUN ("set-process-window-size",
Fset_process_window_size,
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))
@@ -1185,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;
@@ -1194,6 +1225,10 @@ list of keywords. */)
contact = XPROCESS (process)->childp;
#ifdef DATAGRAM_SOCKETS
+
+ if (NETCONN_P (process))
+ wait_for_socket_fds (process, "process-contact");
+
if (DATAGRAM_CONN_P (process)
&& (EQ (key, Qt) || EQ (key, QCremote)))
contact = Fplist_put (contact, QCremote,
@@ -2416,13 +2451,18 @@ 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;
CHECK_PROCESS (process);
+ if (NETCONN_P (process))
+ wait_for_socket_fds (process, "process-datagram-address");
+
if (!DATAGRAM_CONN_P (process))
return Qnil;
@@ -2434,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;
@@ -2442,6 +2485,9 @@ Returns nil upon error setting address, ADDRESS
otherwise. */)
CHECK_PROCESS (process);
+ if (NETCONN_P (process))
+ wait_for_socket_fds (process, "set-process-datagram-address");
+
if (!DATAGRAM_CONN_P (process))
return Qnil;
@@ -2599,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;
@@ -2610,6 +2659,8 @@ 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, "set-network-process-option");
+
s = p->infd;
if (s < 0)
error ("Process is not running");
@@ -2904,137 +2955,625 @@ usage: (make-serial-process &rest ARGS) */)
return 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
- connection has no PID; you cannot signal it. All you can do is
- stop/continue it and deactivate/close it via delete-process. */
-
-DEFUN ("make-network-process", Fmake_network_process, Smake_network_process,
- 0, MANY, 0,
- doc: /* Create and return a network server or client process.
-
-In Emacs, network connections are represented by process objects, so
-input and output work as for subprocesses and `delete-process' closes
-a network connection. However, a network process has no process id,
-it cannot be signaled, and the status codes are different from normal
-processes.
-
-Arguments are specified as keyword/argument pairs. The following
-arguments are defined:
+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 coding_systems = Qt;
+ Lisp_Object val;
-:name NAME -- NAME is name for process. It is modified if necessary
-to make it unique.
+ tem = Fplist_member (contact, QCcoding);
+ if (!NILP (tem) && (!CONSP (tem) || !CONSP (XCDR (tem))))
+ tem = Qnil; /* No error message (too late!). */
-:buffer BUFFER -- BUFFER is the buffer (or buffer-name) to associate
-with the process. Process output goes at end of that buffer, unless
-you specify an output stream or filter function to handle the output.
-BUFFER may be also nil, meaning that this process is not associated
-with any buffer.
+ /* Setup coding systems for communicating with the network stream. */
+ /* Qt denotes we have not yet called Ffind_operation_coding_system. */
-:host HOST -- HOST is name of the host to connect to, or its IP
-address. The symbol `local' specifies the local host. If specified
-for a server process, it must be a valid name or address for the local
-host, and only clients connecting to that address will be accepted.
+ 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);
-:service SERVICE -- SERVICE is name of the service desired, or an
-integer specifying a port number to connect to. If SERVICE is t,
-a random port number is selected for the server. (If Emacs was
-compiled with getaddrinfo, a port number can also be specified as a
-string, e.g. "80", as well as an integer. This is not portable.)
+ 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);
-:type TYPE -- TYPE is the type of connection. The default (nil) is a
-stream type connection, `datagram' creates a datagram type connection,
-`seqpacket' creates a reliable datagram connection.
+ pset_decoding_buf (p, empty_unibyte_string);
+ p->decoding_carryover = 0;
+ pset_encoding_buf (p, empty_unibyte_string);
-:family FAMILY -- FAMILY is the address (and protocol) family for the
-service specified by HOST and SERVICE. The default (nil) is to use
-whatever address family (IPv4 or IPv6) that is defined for the host
-and port number specified by HOST and SERVICE. Other address families
-supported are:
- local -- for a local (i.e. UNIX) address specified by SERVICE.
- ipv4 -- use IPv4 address family only.
- ipv6 -- use IPv6 address family only.
+ p->inherit_coding_system_flag
+ = !(!NILP (tem) || NILP (p->buffer) || !inherit_process_coding_system);
+}
-:local ADDRESS -- ADDRESS is the local address used for the connection.
-This parameter is ignored when opening a client process. When specified
-for a server process, the FAMILY, HOST and SERVICE args are ignored.
+#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;
-:remote ADDRESS -- ADDRESS is the remote partner's address for the
-connection. This parameter is ignored when opening a stream server
-process. For a datagram server process, it specifies the initial
-setting of the remote datagram address. When specified for a client
-process, the FAMILY, HOST, and SERVICE args are ignored.
+ if (!NILP (Ffboundp (Qnsm_verify_connection)))
+ result = call3 (Qnsm_verify_connection,
+ proc,
+ Fplist_get (contact, QChost),
+ Fplist_get (contact, QCservice));
-The format of ADDRESS depends on the address family:
-- An IPv4 address is represented as an vector of integers [A B C D P]
-corresponding to numeric IP address A.B.C.D and port number P.
-- A local address is represented as a string with the address in the
-local address space.
-- An "unsupported family" address is represented by a cons (F . AV)
-where F is the family number and AV is a vector containing the socket
-address data with one element per address data byte. Do not rely on
-this format in portable code, as it may depend on implementation
-defined constants, data sizes, and data structure alignment.
+ 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
-:coding CODING -- If CODING is a symbol, it specifies the coding
-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.
+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 = NULL;
+ int ret;
+ int addrlen;
+ struct Lisp_Process *p = XPROCESS (proc);
+ Lisp_Object contact = p->childp;
+ int optbits = 0;
-: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.
+ /* Do this in case we never enter the while-loop below. */
+ count1 = SPECPDL_INDEX ();
+ s = -1;
-:noquery BOOL -- Query the user unless BOOL is non-nil, and process is
-running when Emacs is exited.
+ while (!NILP (ip_addresses))
+ {
+ ip_address = XCAR (ip_addresses);
+ ip_addresses = XCDR (ip_addresses);
-:stop BOOL -- Start process in the `stopped' state if BOOL non-nil.
-In the stopped state, a server process does not accept new
-connections, and a client process does not handle incoming traffic.
-The stopped state is cleared by `continue-process' and set by
-`stop-process'.
+#ifdef WINDOWSNT
+ retry_connect:
+#endif
-:filter FILTER -- Install FILTER as the process filter.
+ addrlen = get_lisp_to_sockaddr_size (ip_address, &family);
+ if (sa)
+ free (sa);
+ sa = xmalloc (addrlen);
+ conv_lisp_to_sockaddr (family, ip_address, sa, addrlen);
-:filter-multibyte BOOL -- If BOOL is non-nil, strings given to the
-process filter are multibyte, otherwise they are unibyte.
-If this keyword is not specified, the strings are multibyte if
-the default value of `enable-multibyte-characters' is non-nil.
+ s = socket (family, p->socktype | SOCK_CLOEXEC, p->ai_protocol);
+ if (s < 0)
+ {
+ xerrno = errno;
+ continue;
+ }
-:sentinel SENTINEL -- Install SENTINEL as the process sentinel.
+#ifdef DATAGRAM_SOCKETS
+ if (!p->is_server && p->socktype == SOCK_DGRAM)
+ break;
+#endif /* DATAGRAM_SOCKETS */
-:log LOG -- Install LOG as the server process log function. This
-function is called when the server accepts a network connection from a
-client. The arguments are SERVER, CLIENT, and MESSAGE, where SERVER
-is the server process, CLIENT is the new process for the connection,
-and MESSAGE is a string.
+#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
-:plist PLIST -- Install PLIST as the new process's initial plist.
+ /* Make us close S if quit. */
+ record_unwind_protect_int (close_file_unwind, s);
-: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
-pending connection queue (also known as the backlog); the default
-queue length is 5. Default is to create a client process.
+ /* 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;
-The following network options can be specified for this connection:
+ while (!NILP (params))
+ {
+ key = XCAR (params);
+ params = XCDR (params);
+ val = XCAR (params);
+ params = XCDR (params);
+ optbits |= set_socket_option (s, key, val);
+ }
+ }
-:broadcast BOOL -- Allow send and receive of datagram broadcasts.
-:dontroute BOOL -- Only send to directly connected hosts.
-:keepalive BOOL -- Send keep-alive messages on network stream.
-:linger BOOL or TIMEOUT -- Send queued messages before closing.
-:oobinline BOOL -- Place out-of-band data in receive data stream.
-:priority INT -- Set protocol defined priority for sent packets.
-:reuseaddr BOOL -- Allow reusing a recently used local address
- (this is allowed by default for a server process).
-:bindtodevice NAME -- bind to interface NAME. Using this may require
- special privileges on some systems.
+ if (p->is_server)
+ {
+ /* Configure as a server socket. */
-Consult the relevant system programmer's manual pages for more
-information on using these options.
+ /* 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);
+ // 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
+
+ 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? QClocal: QCremote,
+ 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 up the masks based on the process filter. */
+ set_process_filter_masks (p);
+
+ setup_process_coding_systems (proc);
+
+#ifdef HAVE_GNUTLS
+ /* Continue the asynchronous connection. */
+ if (!NILP (p->gnutls_boot_parameters))
+ {
+ Lisp_Object boot, params = p->gnutls_boot_parameters;
+
+ boot = Fgnutls_boot (proc, XCAR (params), XCDR (params));
+ p->gnutls_boot_parameters = Qnil;
+
+ 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))
+ pset_status (p, list2 (Qfailed,
+ build_string ("TLS negotiation failed")));
+ else
+ pset_status (p, list2 (Qfailed, boot));
+ }
+ }
+#endif
+
+}
+
+#ifndef HAVE_GETADDRINFO
+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;
+}
+#endif
+
+/* 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
+ connection has no PID; you cannot signal it. All you can do is
+ stop/continue it and deactivate/close it via delete-process. */
+
+DEFUN ("make-network-process", Fmake_network_process, Smake_network_process,
+ 0, MANY, 0,
+ doc: /* Create and return a network server or client process.
+
+In Emacs, network connections are represented by process objects, so
+input and output work as for subprocesses and `delete-process' closes
+a network connection. However, a network process has no process id,
+it cannot be signaled, and the status codes are different from normal
+processes.
+
+Arguments are specified as keyword/argument pairs. The following
+arguments are defined:
+
+:name NAME -- NAME is name for process. It is modified if necessary
+to make it unique.
+
+:buffer BUFFER -- BUFFER is the buffer (or buffer-name) to associate
+with the process. Process output goes at end of that buffer, unless
+you specify an output stream or filter function to handle the output.
+BUFFER may be also nil, meaning that this process is not associated
+with any buffer.
+
+:host HOST -- HOST is name of the host to connect to, or its IP
+address. The symbol `local' specifies the local host. If specified
+for a server process, it must be a valid name or address for the local
+host, and only clients connecting to that address will be accepted.
+
+:service SERVICE -- SERVICE is name of the service desired, or an
+integer specifying a port number to connect to. If SERVICE is t,
+a random port number is selected for the server. (If Emacs was
+compiled with getaddrinfo, a port number can also be specified as a
+string, e.g. "80", as well as an integer. This is not portable.)
+
+:type TYPE -- TYPE is the type of connection. The default (nil) is a
+stream type connection, `datagram' creates a datagram type connection,
+`seqpacket' creates a reliable datagram connection.
+
+:family FAMILY -- FAMILY is the address (and protocol) family for the
+service specified by HOST and SERVICE. The default (nil) is to use
+whatever address family (IPv4 or IPv6) that is defined for the host
+and port number specified by HOST and SERVICE. Other address families
+supported are:
+ local -- for a local (i.e. UNIX) address specified by SERVICE.
+ ipv4 -- use IPv4 address family only.
+ ipv6 -- use IPv6 address family only.
+
+:local ADDRESS -- ADDRESS is the local address used for the connection.
+This parameter is ignored when opening a client process. When specified
+for a server process, the FAMILY, HOST and SERVICE args are ignored.
+
+:remote ADDRESS -- ADDRESS is the remote partner's address for the
+connection. This parameter is ignored when opening a stream server
+process. For a datagram server process, it specifies the initial
+setting of the remote datagram address. When specified for a client
+process, the FAMILY, HOST, and SERVICE args are ignored.
+
+The format of ADDRESS depends on the address family:
+- An IPv4 address is represented as an vector of integers [A B C D P]
+corresponding to numeric IP address A.B.C.D and port number P.
+- A local address is represented as a string with the address in the
+local address space.
+- An "unsupported family" address is represented by a cons (F . AV)
+where F is the family number and AV is a vector containing the socket
+address data with one element per address data byte. Do not rely on
+this format in portable code, as it may depend on implementation
+defined constants, data sizes, and data structure alignment.
+
+:coding CODING -- If CODING is a symbol, it specifies the coding
+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 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.
+
+:noquery BOOL -- Query the user unless BOOL is non-nil, and process is
+running when Emacs is exited.
+
+:stop BOOL -- Start process in the `stopped' state if BOOL non-nil.
+In the stopped state, a server process does not accept new
+connections, and a client process does not handle incoming traffic.
+The stopped state is cleared by `continue-process' and set by
+`stop-process'.
+
+:filter FILTER -- Install FILTER as the process filter.
+
+:filter-multibyte BOOL -- If BOOL is non-nil, strings given to the
+process filter are multibyte, otherwise they are unibyte.
+If this keyword is not specified, the strings are multibyte if
+the default value of `enable-multibyte-characters' is non-nil.
+
+:sentinel SENTINEL -- Install SENTINEL as the process sentinel.
+
+:log LOG -- Install LOG as the server process log function. This
+function is called when the server accepts a network connection from a
+client. The arguments are SERVER, CLIENT, and MESSAGE, where SERVER
+is the server process, CLIENT is the new process for the connection,
+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 (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).
+If QLEN is an integer, it is used as the max. length of the server's
+pending connection queue (also known as the backlog); the default
+queue length is 5. Default is to create a client process.
+
+The following network options can be specified for this connection:
+
+:broadcast BOOL -- Allow send and receive of datagram broadcasts.
+:dontroute BOOL -- Only send to directly connected hosts.
+:keepalive BOOL -- Send keep-alive messages on network stream.
+:linger BOOL or TIMEOUT -- Send queued messages before closing.
+:oobinline BOOL -- Place out-of-band data in receive data stream.
+:priority INT -- Set protocol defined priority for sent packets.
+:reuseaddr BOOL -- Allow reusing a recently used local address
+ (this is allowed by default for a server process).
+:bindtodevice NAME -- bind to interface NAME. Using this may require
+ special privileges on some systems.
+
+Consult the relevant system programmer's manual pages for more
+information on using these options.
A server process will listen for and accept connections from clients.
@@ -3067,41 +3606,26 @@ usage: (make-network-process &rest ARGS) */)
Lisp_Object proc;
Lisp_Object contact;
struct Lisp_Process *p;
-#ifdef HAVE_GETADDRINFO
- struct addrinfo ai, *res, *lres;
- struct addrinfo hints;
+#if defined(HAVE_GETADDRINFO) || defined(HAVE_GETADDRINFO_A)
+ 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;
+#endif
#ifdef HAVE_LOCAL_SOCKETS
struct sockaddr_un address_un;
#endif
- int port;
- 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. */
+ int port = 0;
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;
+#ifdef HAVE_GETADDRINFO_A
+ struct gaicb **dns_requests = NULL;
+#endif
+ ptrdiff_t count = SPECPDL_INDEX ();
if (nargs == 0)
return Qnil;
@@ -3129,31 +3653,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);
@@ -3161,23 +3660,20 @@ 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 */
- 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,14 +3702,21 @@ 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);
/* :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. */
+#ifdef HAVE_LOCAL_SOCKETS
+ if (family != AF_LOCAL)
+#endif
+ host = build_string ("127.0.0.1");
+ }
+ else
{
if (EQ (host, Qlocal))
/* Depending on setup, "localhost" may map to different IPv4 and/or
@@ -3232,13 +3735,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
@@ -3254,9 +3753,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))
{
@@ -3275,19 +3772,54 @@ usage: (make-network-process &rest ARGS) */)
portstring = SSDATA (service);
}
+ hints = xzalloc (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))
+ {
+ 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));
+ 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);
+
+ 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))
+ {
+ struct addrinfo *res, *lres;
+ int ret;
+
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));
@@ -3296,6 +3828,19 @@ usage: (make-network-process &rest ARGS) */)
#endif
immediate_quit = 0;
+ for (lres = res; lres; lres = lres->ai_next)
+ {
+ ip_addresses = Fcons (conv_sockaddr_to_lisp
+ (lres->ai_addr, lres->ai_addrlen),
+ ip_addresses);
+ ai_protocol = lres->ai_protocol;
+ }
+
+ ip_addresses = Fnreverse (ip_addresses);
+
+ freeaddrinfo (res);
+ xfree (hints);
+
goto open_socket;
}
#endif /* HAVE_GETADDRINFO */
@@ -3306,7 +3851,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;
@@ -3315,14 +3860,9 @@ 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);
}
- 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))
{
@@ -3334,279 +3874,43 @@ usage: (make-network-process &rest ARGS) */)
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;
- }
-#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 (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);
- }
+ res_init ();
#endif
- contact = Fplist_put (contact, colon_address,
- conv_sockaddr_to_lisp (lres->ai_addr,
lres->ai_addrlen));
-#ifdef HAVE_GETSOCKNAME
- if (!is_server)
+
+ host_info_ptr = gethostbyname ((const char *) SDATA (host));
+ immediate_quit = 0;
+
+ if (host_info_ptr)
{
- 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_numerical_to_lisp
+ ((unsigned char *) host_info_ptr->h_addr,
+ host_info_ptr->h_length,
+ port),
+ Qnil);
}
-#endif
- }
-
- immediate_quit = 0;
+ else
+ /* Attempt to interpret host as numeric inet address. This
+ only works for IPv4 addresses. */
+ {
+ unsigned long numeric_addr = inet_addr (SSDATA (host));
-#ifdef HAVE_GETADDRINFO
- if (res != &ai)
- {
- block_input ();
- freeaddrinfo (res);
- unblock_input ();
- }
-#endif
+ if (numeric_addr == -1)
+ error ("Unknown host \"%s\"", SDATA (host));
- 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 (is_non_blocking_client)
- return Qnil;
+ ip_addresses = Fcons (conv_numerical_to_lisp
+ ((unsigned char *) &numeric_addr, 4, port),
+ 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,134 +3924,62 @@ 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;
+#ifdef HAVE_GETADDRINFO_A
+ p->dns_requests = NULL;
+#endif
+#ifdef HAVE_GNUTLS
+ tem = Fplist_get (contact, QCtls_parameters);
+ CHECK_LIST (tem);
+ p->gnutls_boot_parameters = tem;
+#endif
- 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;
+ set_network_socket_coding_system (proc, service, host, name);
- /* Unwind bind_polling_period and request_sigio. */
unbind_to (count, Qnil);
- if (is_server && socktype != SOCK_DGRAM)
- pset_status (p, Qlisten);
+ /* :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. */
+ p->is_server = 1;
+ if (TYPE_RANGED_INTEGERP (int, tem))
+ p->backlog = XINT (tem);
+ }
- /* 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)));
+ /* :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
+ }
-#ifdef NON_BLOCKING_CONNECT
- if (is_non_blocking_client)
+#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))
{
- /* 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++;
- }
+ p->dns_requests = dns_requests;
+ p->status = Qconnect;
}
else
+ {
+ connect_network_socket (proc, ip_addresses);
+ }
+#else /* HAVE_GETADDRINFO_A */
+ connect_network_socket (proc, ip_addresses);
#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);
return proc;
}
@@ -4453,6 +4685,92 @@ server_accept_connection (Lisp_Object server, int
channel)
exec_sentinel (proc, concat3 (open_from, host_string, nl));
}
+#ifdef HAVE_GETADDRINFO_A
+static Lisp_Object
+check_for_dns (Lisp_Object proc)
+{
+ struct Lisp_Process *p = XPROCESS (proc);
+ Lisp_Object ip_addresses = Qnil;
+ int ret = 0;
+
+ /* Sanity check. */
+ if (! p->dns_requests)
+ return Qnil;
+
+ ret = gai_error (p->dns_requests[0]);
+ if (ret == EAI_INPROGRESS)
+ return Qt;
+
+ /* We got a response. */
+ if (ret == 0)
+ {
+ struct addrinfo *res;
+
+ 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),
+ ip_addresses);
+ }
+
+ ip_addresses = Fnreverse (ip_addresses);
+ }
+ /* The DNS lookup failed. */
+ else if (EQ (p->status, Qconnect))
+ {
+ 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")))));
+ }
+
+ free_dns_request (proc);
+
+ /* This process should not already be connected (or killed). */
+ if (!EQ (p->status, Qconnect))
+ return Qnil;
+
+ return ip_addresses;
+}
+
+#endif /* HAVE_GETADDRINFO_A */
+
+static void
+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));
+ 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))
+ {
+ add_to_log ("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 (XPROCESS (process)->gnutls_p &&
+ XPROCESS (process)->gnutls_initstage != GNUTLS_STAGE_READY)
+ {
+ add_to_log ("Waiting for TLS...\n");
+ wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0);
+ }
+#endif
+}
+
/* 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
@@ -4578,6 +4896,55 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
if (! NILP (wait_for_cell) && ! NILP (XCAR (wait_for_cell)))
break;
+#if defined (HAVE_GETADDRINFO_A) || defined (HAVE_GNUTLS)
+ {
+ Lisp_Object ip_addresses;
+ Lisp_Object process_list_head, aproc;
+ struct Lisp_Process *p;
+
+ FOR_EACH_PROCESS(process_list_head, aproc)
+ {
+ p = XPROCESS (aproc);
+
+ if (! wait_proc || p == wait_proc)
+ {
+#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)
+ {
+ gnutls_verify_boot (proc, Qnil);
+ finish_after_tls_connection (aproc);
+ }
+ else if (p->gnutls_handshakes_tried >
+ GNUTLS_EMACS_HANDSHAKES_LIMIT)
+ {
+ deactivate_process (aproc);
+ pset_status (p, list2 (Qfailed,
+ build_string ("TLS negotiation
failed")));
+ }
+ }
+#endif
+ }
+ }
+ }
+#endif /* GETADDRINFO_A or GNUTLS */
+
/* Compute time from now till when time limit is up. */
/* Exit if already run out. */
if (wait == TIMEOUT)
@@ -5197,11 +5564,21 @@ 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"));
+#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
+ 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))
{
@@ -5658,6 +6035,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))
@@ -5875,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);
@@ -5889,6 +6274,9 @@ Output from processes can arrive in between bunches. */)
if (XINT (start) < GPT && XINT (end) > GPT)
move_gap_both (XINT (start), start_byte);
+ if (NETCONN_P (proc))
+ wait_while_connecting (proc);
+
send_process (proc, (char *) BYTE_POS_ADDR (start_byte),
end_byte - start_byte, Fcurrent_buffer ());
@@ -5902,12 +6290,16 @@ 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;
CHECK_STRING (string);
proc = get_process (process);
+
send_process (proc, SSDATA (string),
SBYTES (string), string);
return Qnil;
@@ -6322,10 +6714,15 @@ process has been transmitted to the serial port. */)
struct coding_system *coding = NULL;
int outfd;
- if (DATAGRAM_CONN_P (process))
+ proc = get_process (process);
+
+ if (NETCONN_P (proc))
+ wait_while_connecting (proc);
+
+ if (DATAGRAM_CONN_P (proc))
return process;
- proc = get_process (process);
+
outfd = XPROCESS (proc)->outfd;
if (outfd >= 0)
coding = proc_encode_coding_system[outfd];
@@ -6770,13 +7167,21 @@ 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;
CHECK_PROCESS (process);
+
+ if (NETCONN_P (process))
+ wait_for_socket_fds (process, "set-process-coding-system");
+
p = XPROCESS (process);
+
if (p->infd < 0)
error ("Input file descriptor of %s closed", SDATA (p->name));
if (p->outfd < 0)
@@ -6813,6 +7218,10 @@ suppressed. */)
register struct Lisp_Process *p;
CHECK_PROCESS (process);
+
+ if (NETCONN_P (process))
+ wait_for_socket_fds (process, "set-process-filter-multibyte");
+
p = XPROCESS (process);
if (NILP (flag))
pset_decode_coding_system
@@ -7501,6 +7910,8 @@ syms_of_process (void)
DEFSYM (QCserver, ":server");
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");
diff --git a/src/process.h b/src/process.h
index 8d9f8f4..c753157 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_boot_parameters;
#endif
/* Pipe process attached to the standard error of this process. */
@@ -161,7 +162,25 @@ struct Lisp_Process
flag indicates that `raw_status' contains a new status that still
needs to be synced to `status'. */
bool_bf raw_status_new : 1;
+ /* Whether this is a nonblocking socket. */
+ bool_bf is_non_blocking_client : 1;
+ /* Whether this is a server or a client socket. */
+ bool_bf is_server : 1;
int raw_status;
+ /* The length of the socket backlog. */
+ int backlog;
+ /* The port number. */
+ int port;
+ /* The socket type. */
+ int socktype;
+ /* The socket protocol. */
+ int ai_protocol;
+
+#ifdef HAVE_GETADDRINFO_A
+ /* Whether the socket is waiting for response from an asynchronous
+ DNS call. */
+ struct gaicb **dns_requests;
+#endif
#ifdef HAVE_GNUTLS
gnutls_initstage_t gnutls_initstage;
@@ -191,6 +210,12 @@ pset_childp (struct Lisp_Process *p, Lisp_Object val)
p->childp = val;
}
+INLINE void
+pset_status (struct Lisp_Process *p, Lisp_Object val)
+{
+ p->status = val;
+}
+
#ifdef HAVE_GNUTLS
INLINE void
pset_gnutls_cred_type (struct Lisp_Process *p, Lisp_Object val)
diff --git a/test/lisp/net/network-stream-tests.el
b/test/lisp/net/network-stream-tests.el
index a5e146f..c6a20b0 100644
--- a/test/lisp/net/network-stream-tests.el
+++ b/test/lisp/net/network-stream-tests.el
@@ -40,7 +40,7 @@
(should (equal (process-contact server :local) file))
(delete-file (process-contact server :local))))
-(ert-deftest make-local-tcp-server-with-unspecified-port ()
+(ert-deftest make-ipv4-tcp-server-with-unspecified-port ()
(let ((server
(make-network-process
:name "server"
@@ -54,7 +54,7 @@
(> (aref (process-contact server :local) 4) 0)))
(delete-process server)))
-(ert-deftest make-local-tcp-server-with-specified-port ()
+(ert-deftest make-ipv4-tcp-server-with-specified-port ()
(let ((server
(make-network-process
:name "server"
@@ -147,9 +147,6 @@
:nowait t
:service port)))
(should (eq (process-status proc) 'connect))
- (should (null (ignore-errors
- (process-send-string proc "echo bar")
- t)))
(while (eq (process-status proc) 'connect)
(sit-for 0.1))
(with-current-buffer (process-buffer proc)
@@ -158,17 +155,17 @@
(should (equal (buffer-string) "foo\n")))
(delete-process server)))
-(defun make-tls-server ()
+(defun make-tls-server (port)
(start-process "gnutls" (generate-new-buffer "*tls*")
"gnutls-serv" "--http"
"--x509keyfile" "lisp/net/key.pem"
"--x509certfile" "lisp/net/cert.pem"
- "--port" "44330"))
+ "--port" (format "%s" port)))
(ert-deftest connect-to-tls-ipv4-wait ()
(skip-unless (executable-find "gnutls-serv"))
(skip-unless (gnutls-available-p))
- (let ((server (make-tls-server))
+ (let ((server (make-tls-server 44332))
(times 0)
proc status)
(sleep-for 1)
@@ -181,7 +178,7 @@
:name "bar"
:buffer (generate-new-buffer "*foo*")
:host "localhost"
- :service 44330))))
+ :service 44332))))
(< (setq times (1+ times)) 10))
(sit-for 0.1))
(should proc)
@@ -201,11 +198,47 @@
(setq issuer (split-string issuer ","))
(should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
+(ert-deftest connect-to-tls-ipv4-nowait ()
+ (skip-unless (executable-find "gnutls-serv"))
+ (skip-unless (gnutls-available-p))
+ (let ((server (make-tls-server 44331))
+ (times 0)
+ proc status)
+ (sleep-for 1)
+ (with-current-buffer (process-buffer server)
+ (message "gnutls-serv: %s" (buffer-string)))
+
+ ;; It takes a while for gnutls-serv to start.
+ (while (and (null (ignore-errors
+ (setq proc (make-network-process
+ :name "bar"
+ :buffer (generate-new-buffer "*foo*")
+ :nowait t
+ :tls-parameters
+ (cons 'gnutls-x509pki
+ (gnutls-boot-parameters
+ :hostname "localhost"))
+ :host "localhost"
+ :service 44331))))
+ (< (setq times (1+ times)) 10))
+ (sit-for 0.1))
+ (should proc)
+ (while (eq (process-status proc) 'connect)
+ (sit-for 0.1))
+ (delete-process server)
+ (setq status (gnutls-peer-status proc))
+ (should (consp status))
+ (delete-process proc)
+ (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
+ (should (stringp issuer))
+ (setq issuer (split-string issuer ","))
+ (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
+
(ert-deftest connect-to-tls-ipv6-nowait ()
(skip-unless (executable-find "gnutls-serv"))
(skip-unless (gnutls-available-p))
(skip-unless (not (eq system-type 'windows-nt)))
- (let ((server (make-tls-server))
+ (let ((server (make-tls-server 44333))
(times 0)
proc status)
(sleep-for 1)
@@ -219,14 +252,17 @@
:buffer (generate-new-buffer "*foo*")
:family 'ipv6
:nowait t
+ :tls-parameters
+ (cons 'gnutls-x509pki
+ (gnutls-boot-parameters
+ :hostname "localhost"))
:host "::1"
- :service 44330))))
+ :service 44333))))
(< (setq times (1+ times)) 10))
(sit-for 0.1))
(should proc)
- (gnutls-negotiate :process proc
- :type 'gnutls-x509pki
- :hostname "localhost")
+ (while (eq (process-status proc) 'connect)
+ (sit-for 0.1))
(delete-process server)
(setq status (gnutls-peer-status proc))
(should (consp status))