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
;;; 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,23 +101,28 @@ (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))
(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")