summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2023-05-03 19:42:07 +0200
committerLudovic Courtès <ludo@gnu.org>2023-05-04 13:08:59 +0200
commitfc6c96c88a0e4ad0b9e48272e5f97ffaa6eec36e (patch)
tree0f061408dbc020bb63c7806c85ea819d735764bf /guix
parent7a0a186a32524d4156bf96786d708fab323cebff (diff)
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.scm42
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")