mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-25 05:48:07 -05:00
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.
This commit is contained in:
parent
7a0a186a32
commit
fc6c96c88a
1 changed files with 24 additions and 18 deletions
|
@ -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 @@ (define-syntax-rule (catch-EINPROGRESS body ...)
|
|||
(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,13 +101,18 @@ (define (raise-error errno)
|
|||
(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))
|
||||
(let loop ((timeout timeout))
|
||||
(catch-EINPROGRESS (connect s sockaddr))
|
||||
(match (select '() (list s) (list s) timeout)
|
||||
((() () ())
|
||||
;; Time is up!
|
||||
(raise-error ETIMEDOUT))
|
||||
;; 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)
|
||||
|
@ -116,7 +122,7 @@ (define (raise-error errno)
|
|||
((() () (except))
|
||||
;; Seems like this cannot really happen, but who knows.
|
||||
(let ((errno (getsockopt s SOL_SOCKET SO_ERROR)))
|
||||
(raise-error errno)))))
|
||||
(raise-error errno))))))
|
||||
(connect s sockaddr)))
|
||||
|
||||
(define* (ftp-open host #:optional (port "ftp")
|
||||
|
|
Loading…
Reference in a new issue