diff options
author | Ludovic Courtès <ludo@gnu.org> | 2023-05-03 19:42:07 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2023-05-04 13:08:59 +0200 |
commit | fc6c96c88a0e4ad0b9e48272e5f97ffaa6eec36e (patch) | |
tree | 0f061408dbc020bb63c7806c85ea819d735764bf /guix | |
parent | 7a0a186a32524d4156bf96786d708fab323cebff (diff) | |
download | guix-patches-fc6c96c88a0e4ad0b9e48272e5f97ffaa6eec36e.tar guix-patches-fc6c96c88a0e4ad0b9e48272e5f97ffaa6eec36e.tar.gz |
ftp-client: 'connect*' retries until the timeout has expired.
Partly fixes <https://issues.guix.gnu.org/63024>.
Reported by Greg Hogan <code@greghogan.com>
and Timo Wilken <guix@twilken.net>.
* guix/ftp-client.scm (connect*): When 'select' returns an empty set,
try again until TIMEOUT has expired.
Diffstat (limited to 'guix')
-rw-r--r-- | guix/ftp-client.scm | 42 |
1 files changed, 24 insertions, 18 deletions
diff --git a/guix/ftp-client.scm b/guix/ftp-client.scm index c1d99bd75f..73f5040f04 100644 --- a/guix/ftp-client.scm +++ b/guix/ftp-client.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2010-2017, 2019, 2023 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -86,7 +86,8 @@ (lambda () body ...) (lambda args - (unless (= (system-error-errno args) EINPROGRESS) + (unless (memv (system-error-errno args) + (list EINPROGRESS EALREADY)) (apply throw args))))) ;; XXX: For lack of a better place. @@ -100,23 +101,28 @@ seconds to wait for the connection to succeed." (list errno))) (if timeout - (let ((flags (fcntl s F_GETFL))) + (let ((end (+ (current-time) timeout)) + (flags (fcntl s F_GETFL))) (fcntl s F_SETFL (logior flags O_NONBLOCK)) - (catch-EINPROGRESS (connect s sockaddr)) - (match (select '() (list s) (list s) timeout) - ((() () ()) - ;; Time is up! - (raise-error ETIMEDOUT)) - ((() (write) ()) - ;; Check for ECONNREFUSED and the likes. - (fcntl s F_SETFL flags) - (let ((errno (getsockopt s SOL_SOCKET SO_ERROR))) - (unless (zero? errno) - (raise-error errno)))) - ((() () (except)) - ;; Seems like this cannot really happen, but who knows. - (let ((errno (getsockopt s SOL_SOCKET SO_ERROR))) - (raise-error errno))))) + (let loop ((timeout timeout)) + (catch-EINPROGRESS (connect s sockaddr)) + (match (select '() (list s) (list s) timeout) + ((() () ()) + ;; Check whether 'select' returned early. + (let ((now (current-time))) + (if (>= now end) + (raise-error ETIMEDOUT) ;time is up! + (loop (- end now))))) + ((() (write) ()) + ;; Check for ECONNREFUSED and the likes. + (fcntl s F_SETFL flags) + (let ((errno (getsockopt s SOL_SOCKET SO_ERROR))) + (unless (zero? errno) + (raise-error errno)))) + ((() () (except)) + ;; Seems like this cannot really happen, but who knows. + (let ((errno (getsockopt s SOL_SOCKET SO_ERROR))) + (raise-error errno)))))) (connect s sockaddr))) (define* (ftp-open host #:optional (port "ftp") |