diff options
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 38 | ||||
| -rw-r--r-- | guix/web.scm | 112 |
2 files changed, 84 insertions, 66 deletions
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 271a22541a..24e5d68c4f 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -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: diff --git a/guix/web.scm b/guix/web.scm index d24f15853d..321c38391d 100644 --- a/guix/web.scm +++ b/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 |