diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2021-06-25 16:11:55 +0200 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2021-06-25 23:44:15 +0200 |
| commit | b36267b1d96ac344d2b42c9822ce04b4c3117f85 (patch) | |
| tree | 0c8e4a2563e3f08d614a84e4d519ec6d1e123910 | |
| parent | 7fe195f3b79a9a1369fa9f14539f82a5b5c880de (diff) | |
| download | guix-b36267b1d96ac344d2b42c9822ce04b4c3117f85.tar.gz guix-b36267b1d96ac344d2b42c9822ce04b4c3117f85.zip | |
download: 'tls-wrap' retries handshake upon non-fatal errors.
Fixes <https://bugs.gnu.org/49223>.
Reported by Domagoj Stolfa <ds815@gmx.com>.
* guix/build/download.scm (tls-wrap): Retry up to 5 times when
'handshake' throws a non-fatal error.
| -rw-r--r-- | guix/build/download.scm | 36 |
1 files changed, 21 insertions, 15 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm index b14db42352..54627eefa2 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -281,21 +281,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? |