bug#70645: [PATCH 2/2] web: Handle non-blocking ports in tls-wrap.

[Christopher Baines]

As described in the GnuTLS documentation on Asynchronous operation,
GNUTLS_NONBLOCK should be passed to gnutls_init, and the Guile
equivalent is passing connection-flag/nonblock to make-session.

Additionally, error/again or error/interrupted should lead to a retry of
the handshake, after waiting for the appropriate I/O on the port.  As
record-get-direction is new in Guile-GnuTLS, specifically check if this
is defined.

* module/web/client.scm (tls-wrap): Call make-session with
connection-flag/nonblock if the port is non-blocking, and handle waiting
for I/O when performing the handshake.
---
 module/web/client.scm | 24 ++++++++++++++++++++++--
 1 file changed, 22 insertions(+), 2 deletions(-)

diff --git a/module/web/client.scm b/module/web/client.scm
index f26b5d259..caf8e5f35 100644
--- a/module/web/client.scm
+++ b/module/web/client.scm
@@ -33,6 +33,7 @@
 
 (define-module (web client)
   #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 suspendable-ports)
   #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 copy-tree)
   #:use-module (ice-9 iconv)
@@ -225,7 +226,14 @@ host name without trailing dot."
 
   (load-gnutls)
 
-  (let ((session  (make-session connection-end/client))
+  (let ((session
+         (apply
+          make-session
+          (cons connection-end/client
+                (if (zero? (logand O_NONBLOCK (fcntl port F_GETFL)))
+                    '()
+                    ;; If the port is non-blocking, tell GnuTLS
+                    (list connection-flag/nonblock)))))
         (ca-certs (x509-certificate-directory)))
     ;; Some servers such as 'cloud.github.com' require the client to support
     ;; the 'SERVER NAME' extension.  However, 'set-session-server-name!' is
@@ -261,7 +269,19 @@ host name without trailing dot."
         (lambda ()
           (handshake session))
         (lambda (key err proc . rest)
-          (cond ((eq? err error/warning-alert-received)
+          (cond ((and
+                  (or (eq? err error/again)
+                      (eq? err error/interrupted))
+                  (module-defined? (resolve-interface '(gnutls))
+                                   'record-get-direction)) ; Guile-GnuTLS >= 
4.0.0
+                 (if (= 0 (record-get-direction session))
+                     ((current-read-waiter) port)
+                     ((current-write-waiter) port))
+
+                 ;; These errors are expected and just signal that
+                 ;; GnuTLS was interrupted, so don't count the retry
+                 (loop retries))
+                ((eq? err error/warning-alert-received)
                  ;; Like Wget, do no stop upon non-fatal alerts such as
                  ;; 'alert-description/unrecognized-name'.
                  (format (current-error-port)
-- 
2.41.0