[Emacs-diffs] feature/async-dns 0f47153: Implement asynchronous GnuTLS connections

[Lars Ingebrigtsen]

branch: feature/async-dns
commit 0f47153b97ae31b82366a857ec2f937c1580b637
Author: Lars Ingebrigtsen <address@hidden>
Commit: Lars Ingebrigtsen <address@hidden>

    Implement asynchronous GnuTLS connections
    
    * doc/misc/emacs-gnutls.texi (Help For Developers): Mention
    the nowait parameter.
    
    * lisp/net/gnutls.el (open-gnutls-stream): Allow asynchronous
    connections with the new nowait parameter.
    
    * lisp/net/network-stream.el (network-stream-open-tls): Pass
    on :nowait to open-gnutls-stream.
    
    * lisp/url/url-http.el (url-http): Don't overwrite the
    sentinel created by open-gnutls-stream.
    
    * src/gnutls.c (Fgnutls_mark_process): New function.
    
    * src/process.c (send_process): Don't write to GnuTLS sockets that
    haven't been initialised yed.
    
    * src/process.h: New slot gnutls_wait_p.
---
 doc/misc/emacs-gnutls.texi |    5 ++++-
 lisp/net/gnutls.el         |   25 +++++++++++++++++++++----
 lisp/net/network-stream.el |    8 ++++----
 lisp/url/url-http.el       |   12 +++++++++++-
 src/gnutls.c               |   11 +++++++++++
 src/process.c              |    5 +++++
 src/process.h              |    1 +
 7 files changed, 57 insertions(+), 10 deletions(-)

diff --git a/doc/misc/emacs-gnutls.texi b/doc/misc/emacs-gnutls.texi
index 1a850c6..1db6c51 100644
--- a/doc/misc/emacs-gnutls.texi
+++ b/doc/misc/emacs-gnutls.texi
@@ -173,7 +173,7 @@ Just use @code{open-protocol-stream} or 
@code{open-network-stream}
 You should not have to use the @file{gnutls.el} functions directly.
 But you can test them with @code{open-gnutls-stream}.
 
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,9 @@ syntax are the same as those given to 
@code{open-network-stream}
 Manual}).  The connection process is called @var{name} (made unique if
 necessary).  This function returns the connection process.
 
+If called with @var{nowait}, the process is returned immediately
+(before connecting to the server).
+
 @lisp
 ;; open a HTTPS connection
 (open-gnutls-stream "tls" "tls-buffer" "yourserver.com" "https")
diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el
index ce44c03..d6b3696 100644
--- a/lisp/net/gnutls.el
+++ b/lisp/net/gnutls.el
@@ -95,7 +95,7 @@ A value of nil says to use the default GnuTLS value."
                  (integer :tag "Number of bits" 512))
   :group 'gnutls)
 
-(defun open-gnutls-stream (name buffer host service)
+(defun open-gnutls-stream (name buffer host service &optional nowait)
   "Open a SSL/TLS connection for a service to a host.
 Returns a subprocess-object to represent the connection.
 Input and output work as for subprocesses; `delete-process' closes it.
@@ -109,6 +109,8 @@ BUFFER is the buffer (or `buffer-name') to associate with 
the process.
 Third arg is name of the host to connect to, or its IP address.
 Fourth arg SERVICE is name of the service desired, or an integer
 specifying a port number to connect to.
+Fifth arg NOWAIT (which is optional) means that the socket should
+be opened asynchronously.
 
 Usage example:
 
@@ -122,9 +124,24 @@ This is a very simple wrapper around `gnutls-negotiate'.  
See its
 documentation for the specific parameters you can use to open a
 GnuTLS connection, including specifying the credential type,
 trust and key files, and priority string."
-  (gnutls-negotiate :process (open-network-stream name buffer host service)
-                    :type 'gnutls-x509pki
-                    :hostname host))
+  (let ((process (open-network-stream name buffer host service
+                                      :nowait nowait)))
+    (if nowait
+        (progn
+          (gnutls-mark-process process t)
+          (set-process-sentinel process 'gnutls-async-sentinel)
+          process)
+      (gnutls-negotiate :process (open-network-stream name buffer host service)
+                        :type 'gnutls-x509pki
+                        :hostname host))))
+
+(defun gnutls-async-sentinel (process change)
+  (message "change: %S %s" change (car (process-contact process)))
+  (when (string-match "open" change)
+    (gnutls-negotiate :process process
+                      :type 'gnutls-x509pki
+                      :hostname (car (process-contact process)))
+    (gnutls-mark-process process nil)))
 
 (define-error 'gnutls-error "GnuTLS error")
 
diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el
index 59ac299..02af884 100644
--- a/lisp/net/network-stream.el
+++ b/lisp/net/network-stream.el
@@ -359,10 +359,10 @@ asynchronously, if possible."
   (with-current-buffer buffer
     (let* ((start (point-max))
           (stream
-           (funcall (if (gnutls-available-p)
-                        'open-gnutls-stream
-                      'open-tls-stream)
-                    name buffer host service))
+            (if (gnutls-available-p)
+                (open-gnutls-stream name buffer host service
+                                    (plist-get parameters :nowait))
+              (open-tls-stream name buffer host service)))
           (eoc (plist-get parameters :end-of-command)))
       ;; Check certificate validity etc.
       (when (and (gnutls-available-p) stream)
diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el
index 222dbc6..43b2862 100644
--- a/lisp/url/url-http.el
+++ b/lisp/url/url-http.el
@@ -1277,7 +1277,17 @@ The return value of this function is the retrieval 
buffer."
        (pcase (process-status connection)
           (`connect
            ;; Asynchronous connection
-           (set-process-sentinel connection 'url-http-async-sentinel))
+           (if (not (process-sentinel connection))
+               (set-process-sentinel connection 'url-http-async-sentinel)
+             ;; If we already have a sentinel on this process (for
+             ;; instance on TLS connections), then chain them
+             ;; together.
+             (let ((old (process-sentinel connection)))
+               (set-process-sentinel
+                connection
+                `(lambda (proc why)
+                   (funcall ',old proc why)
+                   (url-http-async-sentinel proc why))))))
           (`failed
            ;; Asynchronous connection failed
            (error "Could not create connection to %s:%d" host port))
diff --git a/src/gnutls.c b/src/gnutls.c
index 01a5983..d11b11c 100644
--- a/src/gnutls.c
+++ b/src/gnutls.c
@@ -686,6 +686,16 @@ emacs_gnutls_deinit (Lisp_Object proc)
   return Qt;
 }
 
+DEFUN ("gnutls-mark-process", Fgnutls_mark_process, Sgnutls_mark_process, 2, 
2, 0,
+       doc: /* Mark this process as being a pre-init GnuTLS process.  */)
+  (Lisp_Object proc, Lisp_Object state)
+{
+  CHECK_PROCESS (proc);
+
+  XPROCESS (proc)->gnutls_wait_p = !NILP (state);
+  return Qnil;
+}
+
 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage, Sgnutls_get_initstage, 
1, 1, 0,
        doc: /* Return the GnuTLS init stage of process PROC.
 See also `gnutls-boot'.  */)
@@ -1693,6 +1703,7 @@ syms_of_gnutls (void)
        make_number (GNUTLS_E_APPLICATION_ERROR_MIN));
 
   defsubr (&Sgnutls_get_initstage);
+  defsubr (&Sgnutls_mark_process);
   defsubr (&Sgnutls_errorp);
   defsubr (&Sgnutls_error_fatalp);
   defsubr (&Sgnutls_error_string);
diff --git a/src/process.c b/src/process.c
index 8cfa48d..0fe4518 100644
--- a/src/process.c
+++ b/src/process.c
@@ -5806,6 +5806,11 @@ send_process (Lisp_Object proc, const char *buf, 
ptrdiff_t len,
   if (p->outfd < 0)
     error ("Output file descriptor of %s is closed", SDATA (p->name));
 
+#ifdef HAVE_GNUTLS
+  if (p->gnutls_wait_p)
+    return;
+#endif
+
   coding = proc_encode_coding_system[p->outfd];
   Vlast_coding_system_used = CODING_ID_NAME (coding->id);
 
diff --git a/src/process.h b/src/process.h
index 990bbd5..8bd555b 100644
--- a/src/process.h
+++ b/src/process.h
@@ -192,6 +192,7 @@ struct Lisp_Process
     int gnutls_log_level;
     int gnutls_handshakes_tried;
     bool_bf gnutls_p : 1;
+    bool_bf gnutls_wait_p : 1;
 #endif
 };