diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2022-08-04 15:22:49 +0200 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2022-08-04 15:59:23 +0200 |
| commit | 317b06bf862fd899c39a92e9bcdab6f7e4119c7f (patch) | |
| tree | 413ef4f65f632773070e6a8295608a50d7fa6fd9 | |
| parent | c01ca10b3f175ec7d116f8d2832f438dd4279253 (diff) | |
| download | guile-317b06bf862fd899c39a92e9bcdab6f7e4119c7f.tar.gz | |
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.
| -rw-r--r-- | module/web/client.scm | 36 |
1 files 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? |