ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

ftp-client: 'connect*' retries until the timeout has expired.

Browse source 
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:
Ludovic Courtès 2023-05-03 19:42:07 +02:00
parent 7a0a186a32
commit fc6c96c88a
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 24 additions and 18 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

42
guix/ftp-client.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -86,7 +86,8 @@ (define-syntax-rule (catch-EINPROGRESS body ...)
(lambda () (lambda ()
body ...) body ...)
(lambda args (lambda args
(unless (= (system-error-errno args) EINPROGRESS) (unless (memv (system-error-errno args)
(list EINPROGRESS EALREADY))
(apply throw args))))) (apply throw args)))))
;; XXX: For lack of a better place. ;; XXX: For lack of a better place.
@ -100,23 +101,28 @@ (define (raise-error errno)
(list errno))) (list errno)))
(if timeout (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)) (fcntl s F_SETFL (logior flags O_NONBLOCK))
(catch-EINPROGRESS (connect s sockaddr)) (let loop ((timeout timeout))
(match (select '() (list s) (list s) timeout) (catch-EINPROGRESS (connect s sockaddr))
((() () ()) (match (select '() (list s) (list s) timeout)
;; Time is up! ((() () ())
(raise-error ETIMEDOUT)) ;; Check whether 'select' returned early.
((() (write) ()) (let ((now (current-time)))
;; Check for ECONNREFUSED and the likes. (if (>= now end)
(fcntl s F_SETFL flags) (raise-error ETIMEDOUT) ;time is up!
(let ((errno (getsockopt s SOL_SOCKET SO_ERROR))) (loop (- end now)))))
(unless (zero? errno) ((() (write) ())
(raise-error errno)))) ;; Check for ECONNREFUSED and the likes.
((() () (except)) (fcntl s F_SETFL flags)
;; Seems like this cannot really happen, but who knows. (let ((errno (getsockopt s SOL_SOCKET SO_ERROR)))
(let ((errno (getsockopt s SOL_SOCKET SO_ERROR))) (unless (zero? errno)
(raise-error 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))) (connect s sockaddr)))
(define* (ftp-open host #:optional (port "ftp") (define* (ftp-open host #:optional (port "ftp")