Allow making TLS negotiation blocking

* lisp/net/gnutls.el (gnutls-negotiate): Make negotiation blocking.

* src/gnutls.c (Fgnutls_boot): Provide a new keyword,
:complete-negotiation, to specify that we want complete
negotiation even if the socket is non-blocking.
(gnutls_try_handshake): Complete negotiation if given that keyword.

* src/process.h (L): Added gnutls_complete_negotiation_p.

4 files changed, 22 insertions, 4 deletions

diff --git a/etc/NEWS b/etc/NEWS
index b29d460b19a..92d69d2ccd1 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -150,6 +150,10 @@ If no insurmountable problems before next release, it can stay that way.
 ** `ert-with-function-mocked' of 'ert-x package allows mocking of functions
 in unit tests.
 
+---
+** `gnutls-boot' now takes a parameter :complete-negotiation that says
+that negotiation should complete even on non-blocking sockets.
+
 +++
 ** New functions `window-pixel-width-before-size-change' and
 `window-pixel-height-before-size-change' allow to detect which window
diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el
index 0baf2e34ecd..9ed1c8b8305 100644
--- a/lisp/net/gnutls.el
+++ b/lisp/net/gnutls.el
@@ -175,7 +175,9 @@ For the meaning of the rest of the parameters, see `gnutls-boot-parameters'."
                   :verify-hostname-error verify-hostname-error))
          ret)
     (gnutls-message-maybe
-     (setq ret (gnutls-boot process type params))
+     (setq ret (gnutls-boot process type
+                            (append (list :complete-negotiation t)
+                                    params)))
      "boot: %s" params)
 
     (when (gnutls-errorp ret)
diff --git a/src/gnutls.c b/src/gnutls.c
index 988c0104869..db22c924f0c 100644
--- a/src/gnutls.c
+++ b/src/gnutls.c
@@ -402,8 +402,12 @@ gnutls_try_handshake (struct Lisp_Process *proc)
 {
   gnutls_session_t state = proc->gnutls_state;
   int ret;
+  bool non_blocking = proc->is_non_blocking_client;
 
-  if (proc->is_non_blocking_client)
+  if (proc->gnutls_complete_negotiation_p)
+    non_blocking = false;
+
+  if (non_blocking)
     proc->gnutls_p = true;
 
   do
@@ -412,8 +416,9 @@ gnutls_try_handshake (struct Lisp_Process *proc)
       emacs_gnutls_handle_error (state, ret);
       QUIT;
     }
-  while (ret < 0 && gnutls_error_is_fatal (ret) == 0
-	 && ! proc->is_non_blocking_client);
+  while (ret < 0
+	 && gnutls_error_is_fatal (ret) == 0
+	 && ! non_blocking);
 
   proc->gnutls_initstage = GNUTLS_STAGE_HANDSHAKE_TRIED;
 
@@ -1354,6 +1359,9 @@ t to do all checks.  Currently it can contain `:trustfiles' and
 :min-prime-bits is the minimum accepted number of bits the client will
 accept in Diffie-Hellman key exchange.
 
+:complete-negotiation, if non-nil, will make negotiation complete
+before returning even on non-blocking sockets.
+
 The debug level will be set for this process AND globally for GnuTLS.
 So if you set it higher or lower at any point, it affects global
 debugging.
@@ -1642,6 +1650,8 @@ one trustfile (usually a CA bundle).  */)
 	return gnutls_make_error (ret);
     }
 
+  XPROCESS (proc)->gnutls_complete_negotiation_p =
+    !NILP (Fplist_get (proplist, QCgnutls_complete_negotiation));
   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET;
   ret = emacs_gnutls_handshake (XPROCESS (proc));
   if (ret < GNUTLS_E_SUCCESS)
@@ -1734,6 +1744,7 @@ syms_of_gnutls (void)
   DEFSYM (QCgnutls_bootprop_crlfiles, ":crlfiles");
   DEFSYM (QCgnutls_bootprop_min_prime_bits, ":min-prime-bits");
   DEFSYM (QCgnutls_bootprop_loglevel, ":loglevel");
+  DEFSYM (QCgnutls_complete_negotiation, ":complete-negotiation");
   DEFSYM (QCgnutls_bootprop_verify_flags, ":verify-flags");
   DEFSYM (QCgnutls_bootprop_verify_error, ":verify-error");
 
diff --git a/src/process.h b/src/process.h
index 038d58b7370..95bd1b65363 100644
--- a/src/process.h
+++ b/src/process.h
@@ -193,6 +193,7 @@ struct Lisp_Process
     int gnutls_log_level;
     int gnutls_handshakes_tried;
     bool_bf gnutls_p : 1;
+    bool_bf gnutls_complete_negotiation_p : 1;
 #endif
 };