Verify the TLS connection asynchronously

* src/gnutls.c (gnutls_verify_boot): Refactor out into its own
function so that we can call it asynchronously.
(Fgnutls_boot): Use it.

* src/process.c (wait_reading_process_output): Verify the TLS
negotiation.

3 files changed, 150 insertions, 125 deletions

diff --git a/src/gnutls.c b/src/gnutls.c
index 6573c87cf78..ce4fbf9b7ef 100644
--- a/src/gnutls.c
+++ b/src/gnutls.c
@@ -540,8 +540,6 @@ emacs_gnutls_read (struct Lisp_Process *proc, char *buf, ptrdiff_t nbyte)
   ssize_t rtnval;
   gnutls_session_t state = proc->gnutls_state;
 
-  int log_level = proc->gnutls_log_level;
-
   if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
     return -1;
 
@@ -1032,7 +1030,7 @@ The return value is a property list with top-level keys :warnings and
 
   CHECK_PROCESS (proc);
 
-  if (GNUTLS_INITSTAGE (proc) < GNUTLS_STAGE_INIT)
+  if (GNUTLS_INITSTAGE (proc) != GNUTLS_STAGE_READY)
     return Qnil;
 
   /* Then collect any warnings already computed by the handshake. */
@@ -1176,6 +1174,149 @@ boot_error (struct Lisp_Process *p, const char *m, ...)
     verror (m, ap);
 }
 
+Lisp_Object
+gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist)
+{
+  int ret;
+  struct Lisp_Process *p = XPROCESS (proc);
+  gnutls_session_t state = p->gnutls_state;
+  unsigned int peer_verification;
+  Lisp_Object warnings;
+  int max_log_level = p->gnutls_log_level;
+  Lisp_Object hostname, verify_error;
+  bool verify_error_all = 0;
+  char *c_hostname;
+
+  if (NILP (proplist))
+    proplist = Fcdr (Fplist_get (p->childp, QCtls_parameters));
+
+  verify_error = Fplist_get (proplist, QCgnutls_bootprop_verify_error);
+  hostname = Fplist_get (proplist, QCgnutls_bootprop_hostname);
+
+  if (EQ (verify_error, Qt))
+    {
+      verify_error_all = 1;
+    }
+  else if (NILP (Flistp (verify_error)))
+    {
+      boot_error (p, "gnutls-boot: invalid :verify_error parameter (not a list)");
+      return Qnil;
+    }
+
+  if (!STRINGP (hostname))
+    {
+      boot_error (p, "gnutls-boot: invalid :hostname parameter (not a string)");
+      return Qnil;
+    }
+  c_hostname = SSDATA (hostname);
+
+  /* Now verify the peer, following
+     http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
+     The peer should present at least one certificate in the chain; do a
+     check of the certificate's hostname with
+     gnutls_x509_crt_check_hostname against :hostname.  */
+
+  ret = gnutls_certificate_verify_peers2 (state, &peer_verification);
+  if (ret < GNUTLS_E_SUCCESS)
+    return gnutls_make_error (ret);
+
+  XPROCESS (proc)->gnutls_peer_verification = peer_verification;
+
+  warnings = Fplist_get (Fgnutls_peer_status (proc), intern (":warnings"));
+  if (!NILP (warnings))
+    {
+      Lisp_Object tail;
+      for (tail = warnings; CONSP (tail); tail = XCDR (tail))
+        {
+          Lisp_Object warning = XCAR (tail);
+          Lisp_Object message = Fgnutls_peer_status_warning_describe (warning);
+          if (!NILP (message))
+            GNUTLS_LOG2 (1, max_log_level, "verification:", SSDATA (message));
+        }
+    }
+
+  if (peer_verification != 0)
+    {
+      if (verify_error_all
+          || !NILP (Fmember (QCgnutls_bootprop_trustfiles, verify_error)))
+        {
+	  emacs_gnutls_deinit (proc);
+	  boot_error (p, "Certificate validation failed %s, verification code %x",
+		      c_hostname, peer_verification);
+	  return Qnil;
+        }
+      else
+	{
+          GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:",
+                       c_hostname);
+	}
+    }
+
+  /* Up to here the process is the same for X.509 certificates and
+     OpenPGP keys.  From now on X.509 certificates are assumed.  This
+     can be easily extended to work with openpgp keys as well.  */
+  if (gnutls_certificate_type_get (state) == GNUTLS_CRT_X509)
+    {
+      gnutls_x509_crt_t gnutls_verify_cert;
+      const gnutls_datum_t *gnutls_verify_cert_list;
+      unsigned int gnutls_verify_cert_list_size;
+
+      ret = gnutls_x509_crt_init (&gnutls_verify_cert);
+      if (ret < GNUTLS_E_SUCCESS)
+	return gnutls_make_error (ret);
+
+      gnutls_verify_cert_list =
+	gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size);
+
+      if (gnutls_verify_cert_list == NULL)
+	{
+	  gnutls_x509_crt_deinit (gnutls_verify_cert);
+	  emacs_gnutls_deinit (proc);
+	  boot_error (p, "No x509 certificate was found\n");
+	  return Qnil;
+	}
+
+      /* We only check the first certificate in the given chain.  */
+      ret = gnutls_x509_crt_import (gnutls_verify_cert,
+				       &gnutls_verify_cert_list[0],
+				       GNUTLS_X509_FMT_DER);
+
+      if (ret < GNUTLS_E_SUCCESS)
+	{
+	  gnutls_x509_crt_deinit (gnutls_verify_cert);
+	  return gnutls_make_error (ret);
+	}
+
+      XPROCESS (proc)->gnutls_certificate = gnutls_verify_cert;
+
+      int err = gnutls_x509_crt_check_hostname (gnutls_verify_cert,
+						c_hostname);
+      check_memory_full (err);
+      if (!err)
+	{
+	  XPROCESS (proc)->gnutls_extra_peer_verification |=
+	    CERTIFICATE_NOT_MATCHING;
+          if (verify_error_all
+              || !NILP (Fmember (QCgnutls_bootprop_hostname, verify_error)))
+            {
+	      gnutls_x509_crt_deinit (gnutls_verify_cert);
+	      emacs_gnutls_deinit (proc);
+	      boot_error (p, "The x509 certificate does not match \"%s\"", c_hostname);
+	      return Qnil;
+            }
+	  else
+	    {
+              GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not match:",
+                           c_hostname);
+	    }
+	}
+    }
+
+  /* Set this flag only if the whole initialization succeeded.  */
+  XPROCESS (proc)->gnutls_p = 1;
+
+  return gnutls_make_error (ret);
+}
 
 DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
        doc: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
@@ -1235,14 +1376,12 @@ one trustfile (usually a CA bundle).  */)
 {
   int ret = GNUTLS_E_SUCCESS;
   int max_log_level = 0;
-  bool verify_error_all = 0;
 
   gnutls_session_t state;
   gnutls_certificate_credentials_t x509_cred = NULL;
   gnutls_anon_client_credentials_t anon_cred = NULL;
   Lisp_Object global_init;
   char const *priority_string_ptr = "NORMAL"; /* default priority string.  */
-  unsigned int peer_verification;
   char *c_hostname;
 
   /* Placeholders for the property list elements.  */
@@ -1253,9 +1392,7 @@ one trustfile (usually a CA bundle).  */)
   /* Lisp_Object callbacks; */
   Lisp_Object loglevel;
   Lisp_Object hostname;
-  Lisp_Object verify_error;
   Lisp_Object prime_bits;
-  Lisp_Object warnings;
   struct Lisp_Process *p = XPROCESS (proc);
 
   CHECK_PROCESS (proc);
@@ -1280,19 +1417,8 @@ one trustfile (usually a CA bundle).  */)
   keylist               = Fplist_get (proplist, QCgnutls_bootprop_keylist);
   crlfiles              = Fplist_get (proplist, QCgnutls_bootprop_crlfiles);
   loglevel              = Fplist_get (proplist, QCgnutls_bootprop_loglevel);
-  verify_error          = Fplist_get (proplist, QCgnutls_bootprop_verify_error);
   prime_bits            = Fplist_get (proplist, QCgnutls_bootprop_min_prime_bits);
 
-  if (EQ (verify_error, Qt))
-    {
-      verify_error_all = 1;
-    }
-  else if (NILP (Flistp (verify_error)))
-    {
-      boot_error (p, "gnutls-boot: invalid :verify_error parameter (not a list)");
-      return Qnil;
-    }
-
   if (!STRINGP (hostname))
     {
       boot_error (p, "gnutls-boot: invalid :hostname parameter (not a string)");
@@ -1521,112 +1647,7 @@ one trustfile (usually a CA bundle).  */)
   if (ret < GNUTLS_E_SUCCESS)
     return gnutls_make_error (ret);
 
-  /* Now verify the peer, following
-     http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
-     The peer should present at least one certificate in the chain; do a
-     check of the certificate's hostname with
-     gnutls_x509_crt_check_hostname against :hostname.  */
-
-  ret = gnutls_certificate_verify_peers2 (state, &peer_verification);
-  if (ret < GNUTLS_E_SUCCESS)
-    return gnutls_make_error (ret);
-
-  XPROCESS (proc)->gnutls_peer_verification = peer_verification;
-
-  warnings = Fplist_get (Fgnutls_peer_status (proc), intern (":warnings"));
-  if (!NILP (warnings))
-    {
-      Lisp_Object tail;
-      for (tail = warnings; CONSP (tail); tail = XCDR (tail))
-        {
-          Lisp_Object warning = XCAR (tail);
-          Lisp_Object message = Fgnutls_peer_status_warning_describe (warning);
-          if (!NILP (message))
-            GNUTLS_LOG2 (1, max_log_level, "verification:", SSDATA (message));
-        }
-    }
-
-  if (peer_verification != 0)
-    {
-      if (verify_error_all
-          || !NILP (Fmember (QCgnutls_bootprop_trustfiles, verify_error)))
-        {
-	  emacs_gnutls_deinit (proc);
-	  boot_error (p, "Certificate validation failed %s, verification code %x",
-		      c_hostname, peer_verification);
-	  return Qnil;
-        }
-      else
-	{
-          GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:",
-                       c_hostname);
-	}
-    }
-
-  /* Up to here the process is the same for X.509 certificates and
-     OpenPGP keys.  From now on X.509 certificates are assumed.  This
-     can be easily extended to work with openpgp keys as well.  */
-  if (gnutls_certificate_type_get (state) == GNUTLS_CRT_X509)
-    {
-      gnutls_x509_crt_t gnutls_verify_cert;
-      const gnutls_datum_t *gnutls_verify_cert_list;
-      unsigned int gnutls_verify_cert_list_size;
-
-      ret = gnutls_x509_crt_init (&gnutls_verify_cert);
-      if (ret < GNUTLS_E_SUCCESS)
-	return gnutls_make_error (ret);
-
-      gnutls_verify_cert_list =
-	gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size);
-
-      if (gnutls_verify_cert_list == NULL)
-	{
-	  gnutls_x509_crt_deinit (gnutls_verify_cert);
-	  emacs_gnutls_deinit (proc);
-	  boot_error (p, "No x509 certificate was found\n");
-	  return Qnil;
-	}
-
-      /* We only check the first certificate in the given chain.  */
-      ret = gnutls_x509_crt_import (gnutls_verify_cert,
-				       &gnutls_verify_cert_list[0],
-				       GNUTLS_X509_FMT_DER);
-
-      if (ret < GNUTLS_E_SUCCESS)
-	{
-	  gnutls_x509_crt_deinit (gnutls_verify_cert);
-	  return gnutls_make_error (ret);
-	}
-
-      XPROCESS (proc)->gnutls_certificate = gnutls_verify_cert;
-
-      int err = gnutls_x509_crt_check_hostname (gnutls_verify_cert,
-						c_hostname);
-      check_memory_full (err);
-      if (!err)
-	{
-	  XPROCESS (proc)->gnutls_extra_peer_verification |=
-	    CERTIFICATE_NOT_MATCHING;
-          if (verify_error_all
-              || !NILP (Fmember (QCgnutls_bootprop_hostname, verify_error)))
-            {
-	      gnutls_x509_crt_deinit (gnutls_verify_cert);
-	      emacs_gnutls_deinit (proc);
-	      boot_error (p, "The x509 certificate does not match \"%s\"", c_hostname);
-	      return Qnil;
-            }
-	  else
-	    {
-              GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not match:",
-                           c_hostname);
-	    }
-	}
-    }
-
-  /* Set this flag only if the whole initialization succeeded.  */
-  XPROCESS (proc)->gnutls_p = 1;
-
-  return gnutls_make_error (ret);
+  return gnutls_verify_boot (proc, proplist);
 }
 
 DEFUN ("gnutls-bye", Fgnutls_bye,
diff --git a/src/gnutls.h b/src/gnutls.h
index cb521350b9d..d03332ec2b6 100644
--- a/src/gnutls.h
+++ b/src/gnutls.h
@@ -85,6 +85,7 @@ extern void emacs_gnutls_transport_set_errno (gnutls_session_t state, int err);
 extern Lisp_Object emacs_gnutls_deinit (Lisp_Object);
 extern Lisp_Object emacs_gnutls_global_init (void);
 extern int gnutls_try_handshake (struct Lisp_Process *p);
+extern Lisp_Object gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist);
 
 #endif
 
diff --git a/src/process.c b/src/process.c
index d78b04f9770..4a11e7f8b8f 100644
--- a/src/process.c
+++ b/src/process.c
@@ -4919,7 +4919,10 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
 		    p->gnutls_handshakes_tried++;
 
 		    if (p->gnutls_initstage == GNUTLS_STAGE_READY)
-		      finish_after_tls_connection (aproc);
+		      {
+			gnutls_verify_boot (proc, Qnil);
+			finish_after_tls_connection (aproc);
+		      }
 		    else if (p->gnutls_handshakes_tried >
 			     GNUTLS_EMACS_HANDSHAKES_LIMIT)
 		      {