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 2013-06-29 22:10:06 +02:00
parent 013ce67b19
commit bb7dcaea57
2 changed files with 84 additions and 66 deletions

View File

@ -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
(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~%")))
(http-fetch uri #:text? #f #:buffered? buffered?)))))
(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:

View File

@ -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,18 +142,23 @@ 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 ((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
@ -197,6 +203,6 @@ unbuffered port, suitable for use in `filtered-port'."
(loop uri)))
(else
(error "download failed" uri code
(response-reason-phrase resp)))))))
(response-reason-phrase resp))))))))
;;; web.scm ends here