nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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
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 @@ pairs."
;; Number of seconds after which networking is considered "slow". ;; Number of seconds after which networking is considered "slow".
3) 3)
(define %random-state
(seed->random-state (+ (ash (cdr (gettimeofday)) 32) (getpid))))
(define-syntax-rule (with-timeout duration handler body ...) (define-syntax-rule (with-timeout duration handler body ...)
"Run BODY; when DURATION seconds have expired, call HANDLER, and run BODY "Run BODY; when DURATION seconds have expired, call HANDLER, and run BODY
again." again."
@ -140,11 +143,15 @@ again."
(lambda () (lambda ()
body ...) body ...)
(lambda args (lambda args
;; The SIGALRM triggers EINTR. When that happens, try again. ;; The SIGALRM triggers EINTR, because of the bug at
;; Note: SA_RESTART cannot be used because of ;; <http://lists.gnu.org/archive/html/guile-devel/2013-06/msg00050.html>.
;; <http://bugs.gnu.org/14640>. ;; When that happens, try again. Note: SA_RESTART cannot be
;; used because of <http://bugs.gnu.org/14640>.
(if (= EINTR (system-error-errno args)) (if (= EINTR (system-error-errno args))
(try) (begin
;; Wait a little to avoid bursts.
(usleep (random 3000000 %random-state))
(try))
(apply throw args)))))) (apply throw args))))))
(lambda result (lambda result
(alarm 0) (alarm 0)
@ -168,14 +175,19 @@ provide."
;; sudo tc qdisc add dev eth0 root netem delay 1500ms ;; sudo tc qdisc add dev eth0 root netem delay 1500ms
;; and then cancel with: ;; and then cancel with:
;; sudo tc qdisc del dev eth0 root ;; sudo tc qdisc del dev eth0 root
(with-timeout (if (or timeout? (version>? (version) "2.0.5")) (let ((port #f))
%fetch-timeout (with-timeout (if (or timeout? (version>? (version) "2.0.5"))
0) %fetch-timeout
(begin 0)
(warning (_ "while fetching ~a: server is unresponsive~%") (begin
(uri->string uri)) (warning (_ "while fetching ~a: server is unresponsive~%")
(warning (_ "try `--no-substitutes' if the problem persists~%"))) (uri->string uri))
(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> (define-record-type <cache>
(%make-cache url store-directory wants-mass-query?) (%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"))))) (show-version-and-exit "guix substitute-binary")))))
;;; Local Variable: ;;; Local Variables:
;;; eval: (put 'with-atomic-file-output 'scheme-indent-function 1) ;;; eval: (put 'with-atomic-file-output 'scheme-indent-function 1)
;;; eval: (put 'with-timeout 'scheme-indent-function 1) ;;; eval: (put 'with-timeout 'scheme-indent-function 1)
;;; End: ;;; End:

112
guix/web.scm
View File

@ -27,7 +27,8 @@
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (guix utils) #:use-module (guix utils)
#:export (http-fetch)) #:export (open-socket-for-uri
http-fetch))
;;; Commentary: ;;; Commentary:
;;; ;;;
@ -141,62 +142,67 @@ closed it will also close PORT, unless the KEEP-ALIVE? is true."
(module-define! (resolve-module '(web client)) (module-define! (resolve-module '(web client))
'shutdown (const #f)) '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 "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 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 textual. Follow any HTTP redirection. When BUFFERED? is #f, return an
unbuffered port, suitable for use in `filtered-port'." unbuffered port, suitable for use in `filtered-port'."
(let loop ((uri uri)) (let loop ((uri uri))
(define port (let ((port (or port
(let ((s (open-socket-for-uri uri))) (open-socket-for-uri uri
(unless buffered? #:buffered? buffered?))))
(setvbuf s _IONBF)) (let*-values (((resp data)
s)) ;; 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
(let*-values (((resp data) ;; bytevector, and not an input port. Work around that.
;; Try hard to use the API du jour to get an input port. (if (version>? (version) "2.0.7")
;; On Guile 2.0.5 and before, we can only get a string or (http-get uri #:streaming? #t #:port port) ; 2.0.9+
;; bytevector, and not an input port. Work around that. (if (defined? 'http-get*)
(if (version>? (version) "2.0.7") (http-get* uri #:decode-body? text?
(http-get uri #:streaming? #t #:port port) ; 2.0.9+ #:port port) ; 2.0.7
(if (defined? 'http-get*) (http-get uri #:decode-body? text?
(http-get* uri #:decode-body? text? #:port port)))) ; 2.0.5-
#:port port) ; 2.0.7 ((code)
(http-get uri #:decode-body? text? (response-code resp)))
#:port port)))) ; 2.0.5- (case code
((code) ((200)
(response-code resp))) (let ((len (response-content-length resp)))
(case code (cond ((not data)
((200) (begin
(let ((len (response-content-length resp))) ;; Guile 2.0.5 and earlier did not support chunked
(cond ((not data) ;; transfer encoding, which is required for instance when
(begin ;; fetching %PACKAGE-LIST-URL (see
;; Guile 2.0.5 and earlier did not support chunked ;; <http://lists.gnu.org/archive/html/guile-devel/2011-09/msg00089.html>).
;; transfer encoding, which is required for instance when ;; Normally the `when-guile<=2.0.5' block above fixes
;; fetching %PACKAGE-LIST-URL (see ;; that, but who knows what could happen.
;; <http://lists.gnu.org/archive/html/guile-devel/2011-09/msg00089.html>). (warning (_ "using Guile ~a, which does not support ~s encoding~%")
;; Normally the `when-guile<=2.0.5' block above fixes (version)
;; that, but who knows what could happen. (response-transfer-encoding resp))
(warning (_ "using Guile ~a, which does not support ~s encoding~%") (leave (_ "download failed; use a newer Guile~%")
(version) uri resp)))
(response-transfer-encoding resp)) ((string? data) ; `http-get' from 2.0.5-
(leave (_ "download failed; use a newer Guile~%") (values (open-input-string data) len))
uri resp))) ((bytevector? data) ; likewise
((string? data) ; `http-get' from 2.0.5- (values (open-bytevector-input-port data) len))
(values (open-input-string data) len)) (else ; input port
((bytevector? data) ; likewise (values data len)))))
(values (open-bytevector-input-port data) len)) ((301 ; moved permanently
(else ; input port 302) ; found (redirection)
(values data len))))) (let ((uri (response-location resp)))
((301 ; moved permanently (close-port port)
302) ; found (redirection) (format #t (_ "following redirection to `~a'...~%")
(let ((uri (response-location resp))) (uri->string uri))
(close-port port) (loop uri)))
(format #t (_ "following redirection to `~a'...~%") (else
(uri->string uri)) (error "download failed" uri code
(loop uri))) (response-reason-phrase resp))))))))
(else
(error "download failed" uri code
(response-reason-phrase resp)))))))
;;; web.scm ends here ;;; web.scm ends here