[Guile-commits] 02/03: web: 'tls-wrap' retries handshake upon non-fatal errors.

[Ludovic Courtès]

civodul pushed a commit to branch main
in repository guile.

commit 317b06bf862fd899c39a92e9bcdab6f7e4119c7f
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Thu Aug 4 15:22:49 2022 +0200

    web: 'tls-wrap' retries handshake upon non-fatal errors.
    
    Fixes <https://bugs.gnu.org/49223>.
    Reported by Domagoj Stolfa <ds815@gmx.com>.
    
    Backport of Guix commit b36267b1d96ac344d2b42c9822ce04b4c3117f85.
    
    * guix/build/download.scm (tls-wrap): Retry up to 5 times when
    'handshake' throws a non-fatal error.
---
 module/web/client.scm | 36 +++++++++++++++++++++---------------
 1 file changed, 21 insertions(+), 15 deletions(-)

diff --git a/module/web/client.scm b/module/web/client.scm
index d3356361f..a08c4203c 100644
--- a/module/web/client.scm
+++ b/module/web/client.scm
@@ -259,21 +259,27 @@ host name without trailing dot."
     ;;(set-log-level! 10)
     ;;(set-log-procedure! log)
 
-    (catch 'gnutls-error
-      (lambda ()
-        (handshake session))
-      (lambda (key err proc . rest)
-        (cond ((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)
-                       "warning: TLS warning alert received: ~a~%"
-                       (alert-description->string (alert-get session)))
-               (handshake session))
-              (else
-               ;; XXX: We'd use 'gnutls_error_is_fatal' but (gnutls) doesn't
-               ;; provide a binding for this.
-               (apply throw key err proc rest)))))
+    (let loop ((retries 5))
+      (catch 'gnutls-error
+        (lambda ()
+          (handshake session))
+        (lambda (key err proc . rest)
+          (cond ((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)
+                         "warning: TLS warning alert received: ~a~%"
+                         (alert-description->string (alert-get session)))
+                 (handshake session))
+                (else
+                 (if (or (fatal-error? err) (zero? retries))
+                     (apply throw key err proc rest)
+                     (begin
+                       ;; We got 'error/again' or similar; try again.
+                       (format (current-error-port)
+                               "warning: TLS non-fatal error: ~a~%"
+                               (error->string err))
+                       (loop (- retries 1)))))))))
 
     ;; Verify the server's certificate if needed.
     (when verify-certificate?