[Emacs-diffs] feature/async-dns 4ff81f8 2/2: Further TLS async work

[Lars Ingebrigtsen]

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

    Further TLS async work
    
    * gnutls.c (boot_error): New function to either signal an
    error or return an error code.
    (Fgnutls_boot): Don't signal errors when running asynchronously.
    
    * process.h (pset_status): Move here from process.c to be
    able to use from gnutls.c.
    
    * process.c (connect_network_socket): Do the TLS boot here
    when running asynchronously.
    (wait_reading_process_output): Rework the dns_processes
    handling for more safety.
---
 src/gnutls.c  |   54 ++++++++++++++++++++++++++++++++---------
 src/process.c |   75 +++++++++++++++++++++++++++++++++++++++++----------------
 src/process.h |    6 ++++
 3 files changed, 102 insertions(+), 33 deletions(-)

diff --git a/src/gnutls.c b/src/gnutls.c
index 06459fb..a0b6e0d 100644
--- a/src/gnutls.c
+++ b/src/gnutls.c
@@ -1167,6 +1167,19 @@ emacs_gnutls_global_deinit (void)
 }
 #endif
 
+/* VARARGS 1 */
+static void
+boot_error (struct Lisp_Process *p, const char *m, ...)
+{
+  va_list ap;
+  va_start (ap, m);
+  if (p->is_non_blocking_client)
+    pset_status (p, Qfailed);
+  else
+    verror (m, ap);
+}
+
+
 DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
        doc: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
 Currently only client mode is supported.  Return a success/failure
@@ -1246,16 +1259,23 @@ one trustfile (usually a CA bundle).  */)
   Lisp_Object verify_error;
   Lisp_Object prime_bits;
   Lisp_Object warnings;
+  struct Lisp_Process *p = XPROCESS (proc);
 
   CHECK_PROCESS (proc);
   CHECK_SYMBOL (type);
   CHECK_LIST (proplist);
 
   if (NILP (Fgnutls_available_p ()))
-    error ("GnuTLS not available");
+    {
+      boot_error (p, "GnuTLS not available");
+      return Qnil;
+    }
 
   if (!EQ (type, Qgnutls_x509pki) && !EQ (type, Qgnutls_anon))
-    error ("Invalid GnuTLS credential type");
+    {
+      boot_error (p, "Invalid GnuTLS credential type");
+      return Qnil;
+    }
 
   hostname              = Fplist_get (proplist, QCgnutls_bootprop_hostname);
   priority_string       = Fplist_get (proplist, QCgnutls_bootprop_priority);
@@ -1272,11 +1292,15 @@ one trustfile (usually a CA bundle).  */)
     }
   else if (NILP (Flistp (verify_error)))
     {
-      error ("gnutls-boot: invalid :verify_error parameter (not a list)");
+      boot_error (p, "gnutls-boot: invalid :verify_error parameter (not a 
list)");
+      return Qnil;
     }
 
   if (!STRINGP (hostname))
-    error ("gnutls-boot: invalid :hostname parameter (not a string)");
+    {
+      boot_error (p, "gnutls-boot: invalid :hostname parameter (not a 
string)");
+      return Qnil;
+    }
   c_hostname = SSDATA (hostname);
 
   state = XPROCESS (proc)->gnutls_state;
@@ -1384,7 +1408,8 @@ one trustfile (usually a CA bundle).  */)
          else
            {
              emacs_gnutls_deinit (proc);
-             error ("Invalid trustfile");
+             boot_error (p, "Invalid trustfile");
+             return Qnil;
            }
        }
 
@@ -1408,7 +1433,8 @@ one trustfile (usually a CA bundle).  */)
          else
            {
              emacs_gnutls_deinit (proc);
-             error ("Invalid CRL file");
+             boot_error (p, "Invalid CRL file");
+             return Qnil;
            }
        }
 
@@ -1437,8 +1463,9 @@ one trustfile (usually a CA bundle).  */)
          else
            {
              emacs_gnutls_deinit (proc);
-             error (STRINGP (keyfile) ? "Invalid client cert file"
-                    : "Invalid client key file");
+             boot_error (p, STRINGP (keyfile) ? "Invalid client cert file"
+                         : "Invalid client key file");
+             return Qnil;
            }
        }
     }
@@ -1528,8 +1555,9 @@ one trustfile (usually a CA bundle).  */)
           || !NILP (Fmember (QCgnutls_bootprop_trustfiles, verify_error)))
         {
          emacs_gnutls_deinit (proc);
-         error ("Certificate validation failed %s, verification code %x",
-                c_hostname, peer_verification);
+         boot_error (p, "Certificate validation failed %s, verification code 
%x",
+                     c_hostname, peer_verification);
+         return Qnil;
         }
       else
        {
@@ -1558,7 +1586,8 @@ one trustfile (usually a CA bundle).  */)
        {
          gnutls_x509_crt_deinit (gnutls_verify_cert);
          emacs_gnutls_deinit (proc);
-         error ("No x509 certificate was found\n");
+         boot_error (p, "No x509 certificate was found\n");
+         return Qnil;
        }
 
       /* We only check the first certificate in the given chain.  */
@@ -1586,7 +1615,8 @@ one trustfile (usually a CA bundle).  */)
             {
              gnutls_x509_crt_deinit (gnutls_verify_cert);
              emacs_gnutls_deinit (proc);
-             error ("The x509 certificate does not match \"%s\"", c_hostname);
+             boot_error (p, "The x509 certificate does not match \"%s\"", 
c_hostname);
+             return Qnil;
             }
          else
            {
diff --git a/src/process.c b/src/process.c
index 5526405..afb9825 100644
--- a/src/process.c
+++ b/src/process.c
@@ -385,11 +385,6 @@ pset_sentinel (struct Lisp_Process *p, Lisp_Object val)
   p->sentinel = NILP (val) ? Qinternal_default_process_sentinel : val;
 }
 static void
-pset_status (struct Lisp_Process *p, Lisp_Object val)
-{
-  p->status = val;
-}
-static void
 pset_tty_name (struct Lisp_Process *p, Lisp_Object val)
 {
   p->tty_name = val;
@@ -3309,11 +3304,17 @@ void connect_network_socket (Lisp_Object proc, 
Lisp_Object ip_addresses)
 
 #ifdef HAVE_GNUTLS
   if (!NILP (p->gnutls_async_parameters) && p->is_non_blocking_client) {
-    Fgnutls_boot (proc, Fcar (p->gnutls_async_parameters),
-                 Fcdr (p->gnutls_async_parameters));
+    Lisp_Object params = p->gnutls_async_parameters, boot = Qnil;
+
     p->gnutls_async_parameters = Qnil;
+    boot = Fgnutls_boot (proc, Fcar (params), Fcdr (params));
+    if (STRINGP (boot)) {
+      pset_status (p, Qfailed);
+      deactivate_process (proc);
+    }
   }
 #endif
+
 }
 
 
@@ -3798,6 +3799,9 @@ usage: (make-network-process &rest ARGS)  */)
 #ifdef HAVE_GETADDRINFO_A
   p->dns_requests = NULL;
 #endif
+#ifdef HAVE_GNUTLS
+  p->gnutls_async_parameters = Qnil;
+#endif
 
   unbind_to (count, Qnil);
 
@@ -4545,13 +4549,12 @@ server_accept_connection (Lisp_Object server, int 
channel)
 }
 
 #ifdef HAVE_GETADDRINFO_A
-static int
+static Lisp_Object
 check_for_dns (Lisp_Object proc)
 {
   struct Lisp_Process *p = XPROCESS (proc);
   Lisp_Object ip_addresses = Qnil;
   int ret = 0;
-  int connect = 0;
 
   /* Sanity check. */
   if (! p->dns_requests)
@@ -4559,7 +4562,7 @@ check_for_dns (Lisp_Object proc)
 
   ret = gai_error (p->dns_requests[0]);
   if (ret == EAI_INPROGRESS)
-    return 0;
+    return Qt;
 
   /* We got a response. */
   if (ret == 0)
@@ -4575,10 +4578,13 @@ check_for_dns (Lisp_Object proc)
 
       ip_addresses = Fnreverse (ip_addresses);
       freeaddrinfo (p->dns_requests[0]->ar_result);
-      connect = 1;
     }
+  /* The DNS lookup failed. */
   else
-    pset_status (p, Qfailed);
+    {
+      pset_status (p, Qfailed);
+      deactivate_process (proc);
+    }
 
   xfree ((void *)p->dns_requests[0]->ar_request);
   xfree ((void *)p->dns_requests[0]->ar_name);
@@ -4587,10 +4593,7 @@ check_for_dns (Lisp_Object proc)
   xfree (p->dns_requests);
   p->dns_requests = NULL;
 
-  if (connect)
-    connect_network_socket (proc, ip_addresses);
-
-  return 1;
+  return ip_addresses;
 }
 #endif /* HAVE_GETADDRINFO_A */
 
@@ -4722,18 +4725,47 @@ wait_reading_process_output (intmax_t time_limit, int 
nsecs, int read_kbd,
 #ifdef HAVE_GETADDRINFO_A
       if (!NILP (dns_processes))
        {
-         Lisp_Object dns_list = dns_processes, dns;
+         Lisp_Object dns_list = dns_processes, dns, ip_addresses,
+           answers = Qnil, answer, new = Qnil;
          struct Lisp_Process *p;
 
+         /* This is programmed in a somewhat awkward fashion because
+         calling connect_network_socket might make us end up back
+         here again, and we would have a race condition with
+         segfaults.  So first go through all pending requests and see
+         whether we got any answers. */
          while (!NILP (dns_list))
            {
              dns = Fcar (dns_list);
              dns_list = Fcdr (dns_list);
              p = XPROCESS (dns);
-             if (p && p->dns_requests &&
-                 (! wait_proc || p == wait_proc) &&
-                 check_for_dns (dns))
-               dns_processes = Fdelq (dns, dns_processes);
+             if (p && p->dns_requests)
+               {
+                 if (! wait_proc || p == wait_proc)
+                   {
+                     ip_addresses = check_for_dns (dns);
+                     if (EQ (ip_addresses, Qt))
+                       new = Fcons (dns, new);
+                     else
+                       answers = Fcons (Fcons (dns, ip_addresses), answers);
+                   }
+                 else
+                   new = Fcons (dns, new);
+               }
+           }
+
+         /* Replace with the list of DNS requests still not responded
+            to. */
+         dns_processes = new;
+
+         /* Then continue the connection for the successful
+            requests. */
+         while (!NILP (answers))
+           {
+             answer = Fcar (answers);
+             answers = Fcdr (answers);
+             if (!NILP (Fcdr (answer)))
+               connect_network_socket (Fcar (answer), Fcdr (answer));
            }
        }
 #endif /* HAVE_GETADDRINFO_A */
@@ -7685,6 +7717,7 @@ syms_of_process (void)
 
   staticpro (&Vprocess_alist);
   staticpro (&deleted_pid_list);
+  staticpro (&dns_processes);
 
 #endif /* subprocesses */
 
diff --git a/src/process.h b/src/process.h
index eb34f5f..95c64fa 100644
--- a/src/process.h
+++ b/src/process.h
@@ -210,6 +210,12 @@ pset_childp (struct Lisp_Process *p, Lisp_Object val)
   p->childp = val;
 }
 
+INLINE void
+pset_status (struct Lisp_Process *p, Lisp_Object val)
+{
+  p->status = val;
+}
+
 #ifdef HAVE_GNUTLS
 INLINE void
 pset_gnutls_cred_type (struct Lisp_Process *p, Lisp_Object val)