ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-25 22:08:16 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

substitute-binary: Avoid dangling connections to the server.

Browse source 
* 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
Show stats Download patch file Download diff file Expand all files Collapse all files

38
guix/scripts/substitute-binary.scm
View file

@ -124,6 +124,9 @@ (define %fetch-timeout
;; 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 @@ (define-syntax-rule (with-timeout duration handler body ...)
(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 @@ (define* (fetch uri #:key (buffered? #t) (timeout? #t))
;; 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 @@ (define (guix-substitute-binary . args)
(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
View file

@ -27,7 +27,8 @@ (define-module (guix web)
#: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 @@ (define bad-response
(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