substitute-binary: Avoid dangling connections to the server.
* guix/web.scm (open-socket-for-uri): New procedure. (http-fetch): Add `port' keyword parameter; use it. * guix/scripts/substitute-binary.scm (%random-state): New variable. (with-timeout): Wait a little before retrying. (fetch): Use `open-socket-for-uri', and keep a copy of the socket in variable `port'. Close PORT upon timeout.
This commit is contained in:
Ludovic Courtès
parent
013ce67b19
commit
bb7dcaea57
|
|
@ -124,6 +124,9 @@ pairs."
|
|||
;; Number of seconds after which networking is considered "slow".
|
||||
3)
|
||||
|
||||
(define %random-state
|
||||
(seed->random-state (+ (ash (cdr (gettimeofday)) 32) (getpid))))
|
||||
|
||||
(define-syntax-rule (with-timeout duration handler body ...)
|
||||
"Run BODY; when DURATION seconds have expired, call HANDLER, and run BODY
|
||||
again."
|
||||
|
|
@ -140,11 +143,15 @@ again."
|
|||
(lambda ()
|
||||
body ...)
|
||||
(lambda args
|
||||
;; The SIGALRM triggers EINTR. When that happens, try again.
|
||||
;; Note: SA_RESTART cannot be used because of
|
||||
;; <http://bugs.gnu.org/14640>.
|
||||
;; The SIGALRM triggers EINTR, because of the bug at
|
||||
;; <http://lists.gnu.org/archive/html/guile-devel/2013-06/msg00050.html>.
|
||||
;; When that happens, try again. Note: SA_RESTART cannot be
|
||||
;; used because of <http://bugs.gnu.org/14640>.
|
||||
(if (= EINTR (system-error-errno args))
|
||||
(try)
|
||||
(begin
|
||||
;; Wait a little to avoid bursts.
|
||||
(usleep (random 3000000 %random-state))
|
||||
(try))
|
||||
(apply throw args))))))
|
||||
(lambda result
|
||||
(alarm 0)
|
||||
|
|
@ -168,14 +175,19 @@ provide."
|
|||
;; sudo tc qdisc add dev eth0 root netem delay 1500ms
|
||||
;; and then cancel with:
|
||||
;; sudo tc qdisc del dev eth0 root
|
||||
(with-timeout (if (or timeout? (version>? (version) "2.0.5"))
|
||||
%fetch-timeout
|
||||
0)
|
||||
(begin
|
||||
(warning (_ "while fetching ~a: server is unresponsive~%")
|
||||
(uri->string uri))
|
||||
(warning (_ "try `--no-substitutes' if the problem persists~%")))
|
||||
(http-fetch uri #:text? #f #:buffered? buffered?)))))
|
||||
(let ((port #f))
|
||||
(with-timeout (if (or timeout? (version>? (version) "2.0.5"))
|
||||
%fetch-timeout
|
||||
0)
|
||||
(begin
|
||||
(warning (_ "while fetching ~a: server is unresponsive~%")
|
||||
(uri->string uri))
|
||||
(warning (_ "try `--no-substitutes' if the problem persists~%"))
|
||||
(when port
|
||||
(close-port port)))
|
||||
(begin
|
||||
(set! port (open-socket-for-uri uri #:buffered? buffered?))
|
||||
(http-fetch uri #:text? #f #:port port)))))))
|
||||
|
||||
(define-record-type <cache>
|
||||
(%make-cache url store-directory wants-mass-query?)
|
||||
|
|
@ -535,7 +547,7 @@ PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by
|
|||
(show-version-and-exit "guix substitute-binary")))))
|
||||
|
||||
|
||||
;;; Local Variable:
|
||||
;;; Local Variables:
|
||||
;;; eval: (put 'with-atomic-file-output 'scheme-indent-function 1)
|
||||
;;; eval: (put 'with-timeout 'scheme-indent-function 1)
|
||||
;;; End:
|
||||
|
|
|
|||
112
guix/web.scm
112
guix/web.scm
|
|
@ -27,7 +27,8 @@
|
|||
#:use-module (rnrs bytevectors)
|
||||
#:use-module (guix ui)
|
||||
#:use-module (guix utils)
|
||||
#:export (http-fetch))
|
||||
#:export (open-socket-for-uri
|
||||
http-fetch))
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
|
|
@ -141,62 +142,67 @@ closed it will also close PORT, unless the KEEP-ALIVE? is true."
|
|||
(module-define! (resolve-module '(web client))
|
||||
'shutdown (const #f))
|
||||
|
||||
(define* (http-fetch uri #:key (text? #f) (buffered? #t))
|
||||
(define* (open-socket-for-uri uri #:key (buffered? #t))
|
||||
"Return an open port for URI. When BUFFERED? is false, the returned port is
|
||||
unbuffered."
|
||||
(let ((s ((@ (web client) open-socket-for-uri) uri)))
|
||||
(unless buffered?
|
||||
(setvbuf s _IONBF))
|
||||
s))
|
||||
|
||||
(define* (http-fetch uri #:key port (text? #f) (buffered? #t))
|
||||
"Return an input port containing the data at URI, and the expected number of
|
||||
bytes available or #f. If TEXT? is true, the data at URI is considered to be
|
||||
textual. Follow any HTTP redirection. When BUFFERED? is #f, return an
|
||||
unbuffered port, suitable for use in `filtered-port'."
|
||||
(let loop ((uri uri))
|
||||
(define port
|
||||
(let ((s (open-socket-for-uri uri)))
|
||||
(unless buffered?
|
||||
(setvbuf s _IONBF))
|
||||
s))
|
||||
|
||||
(let*-values (((resp data)
|
||||
;; Try hard to use the API du jour to get an input port.
|
||||
;; On Guile 2.0.5 and before, we can only get a string or
|
||||
;; bytevector, and not an input port. Work around that.
|
||||
(if (version>? (version) "2.0.7")
|
||||
(http-get uri #:streaming? #t #:port port) ; 2.0.9+
|
||||
(if (defined? 'http-get*)
|
||||
(http-get* uri #:decode-body? text?
|
||||
#:port port) ; 2.0.7
|
||||
(http-get uri #:decode-body? text?
|
||||
#:port port)))) ; 2.0.5-
|
||||
((code)
|
||||
(response-code resp)))
|
||||
(case code
|
||||
((200)
|
||||
(let ((len (response-content-length resp)))
|
||||
(cond ((not data)
|
||||
(begin
|
||||
;; Guile 2.0.5 and earlier did not support chunked
|
||||
;; transfer encoding, which is required for instance when
|
||||
;; fetching %PACKAGE-LIST-URL (see
|
||||
;; <http://lists.gnu.org/archive/html/guile-devel/2011-09/msg00089.html>).
|
||||
;; Normally the `when-guile<=2.0.5' block above fixes
|
||||
;; that, but who knows what could happen.
|
||||
(warning (_ "using Guile ~a, which does not support ~s encoding~%")
|
||||
(version)
|
||||
(response-transfer-encoding resp))
|
||||
(leave (_ "download failed; use a newer Guile~%")
|
||||
uri resp)))
|
||||
((string? data) ; `http-get' from 2.0.5-
|
||||
(values (open-input-string data) len))
|
||||
((bytevector? data) ; likewise
|
||||
(values (open-bytevector-input-port data) len))
|
||||
(else ; input port
|
||||
(values data len)))))
|
||||
((301 ; moved permanently
|
||||
302) ; found (redirection)
|
||||
(let ((uri (response-location resp)))
|
||||
(close-port port)
|
||||
(format #t (_ "following redirection to `~a'...~%")
|
||||
(uri->string uri))
|
||||
(loop uri)))
|
||||
(else
|
||||
(error "download failed" uri code
|
||||
(response-reason-phrase resp)))))))
|
||||
(let ((port (or port
|
||||
(open-socket-for-uri uri
|
||||
#:buffered? buffered?))))
|
||||
(let*-values (((resp data)
|
||||
;; Try hard to use the API du jour to get an input port.
|
||||
;; On Guile 2.0.5 and before, we can only get a string or
|
||||
;; bytevector, and not an input port. Work around that.
|
||||
(if (version>? (version) "2.0.7")
|
||||
(http-get uri #:streaming? #t #:port port) ; 2.0.9+
|
||||
(if (defined? 'http-get*)
|
||||
(http-get* uri #:decode-body? text?
|
||||
#:port port) ; 2.0.7
|
||||
(http-get uri #:decode-body? text?
|
||||
#:port port)))) ; 2.0.5-
|
||||
((code)
|
||||
(response-code resp)))
|
||||
(case code
|
||||
((200)
|
||||
(let ((len (response-content-length resp)))
|
||||
(cond ((not data)
|
||||
(begin
|
||||
;; Guile 2.0.5 and earlier did not support chunked
|
||||
;; transfer encoding, which is required for instance when
|
||||
;; fetching %PACKAGE-LIST-URL (see
|
||||
;; <http://lists.gnu.org/archive/html/guile-devel/2011-09/msg00089.html>).
|
||||
;; Normally the `when-guile<=2.0.5' block above fixes
|
||||
;; that, but who knows what could happen.
|
||||
(warning (_ "using Guile ~a, which does not support ~s encoding~%")
|
||||
(version)
|
||||
(response-transfer-encoding resp))
|
||||
(leave (_ "download failed; use a newer Guile~%")
|
||||
uri resp)))
|
||||
((string? data) ; `http-get' from 2.0.5-
|
||||
(values (open-input-string data) len))
|
||||
((bytevector? data) ; likewise
|
||||
(values (open-bytevector-input-port data) len))
|
||||
(else ; input port
|
||||
(values data len)))))
|
||||
((301 ; moved permanently
|
||||
302) ; found (redirection)
|
||||
(let ((uri (response-location resp)))
|
||||
(close-port port)
|
||||
(format #t (_ "following redirection to `~a'...~%")
|
||||
(uri->string uri))
|
||||
(loop uri)))
|
||||
(else
|
||||
(error "download failed" uri code
|
||||
(response-reason-phrase resp))))))))
|
||||
|
||||
;;; web.scm ends here
|
||||
|
|
|
|||
Loading…
Reference in New Issue