From 101d9f3fd43b436d5dc7ef13e644c7fbbc7f62d5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 15 May 2013 23:40:09 +0200 Subject: substitute-binary: Pass `filtered-port' an unbuffered port. This fixes a bug whereby `read-response' would read more than just the response, with the extra data going into the port's buffer; the "bzip2 -dc" process spawned by `filtered-port' would not see the those buffered data, which are definitely lost, and would bail out with "bzip2: (stdin) is not a bzip2 file." * guix/utils.scm (filtered-port): Document that INPUT must be unbuffered. * guix/web.scm (http-fetch): Add `buffered?' parameter. Call `open-socket-for-uri' explicitly, and call `setvbuf' when BUFFERED? is false. Pass the port to `http-get'. Close it upon 301/302. * guix/scripts/substitute-binary.scm (fetch): Add `buffered?' parameter. Pass it to `http-fetch'; honor it for `file' URIs. (guix-substitute-binary): Call `fetch' with #:buffered? #f for port RAW. * tests/utils.scm ("filtered-port, file"): Open FILE as unbuffered. --- guix/scripts/substitute-binary.scm | 8 +++++--- guix/utils.scm | 3 ++- guix/web.scm | 23 +++++++++++++++++------ 3 files changed, 24 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 27a43b9e3f..1317a72fb1 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -117,15 +117,17 @@ pairs." (else (error "unmatched line" line))))) -(define (fetch uri) +(define* (fetch uri #:key (buffered? #t)) "Return a binary input port to URI and the number of bytes it's expected to provide." (case (uri-scheme uri) ((file) (let ((port (open-input-file (uri-path uri)))) + (unless buffered? + (setvbuf port _IONBF)) (values port (stat:size (stat port))))) ((http) - (http-fetch uri #:text? #f)))) + (http-fetch uri #:text? #f #:buffered? buffered?)))) (define-record-type (%make-cache url store-directory wants-mass-query?) @@ -423,7 +425,7 @@ indefinitely." (format #t "~a~%" (narinfo-hash narinfo)) (let*-values (((raw download-size) - (fetch uri)) + (fetch uri #:buffered? #f)) ((input pids) (decompressed-port (narinfo-compression narinfo) raw))) diff --git a/guix/utils.scm b/guix/utils.scm index c2d2808f76..25a392e6a8 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -163,7 +163,8 @@ evaluate to a simple datum." (define (filtered-port command input) "Return an input port where data drained from INPUT is filtered through COMMAND (a list). In addition, return a list of PIDs that the caller must -wait." +wait. When INPUT is a file port, it must be unbuffered; otherwise, any +buffered data is lost." (let loop ((input input) (pids '())) (if (file-port? input) diff --git a/guix/web.scm b/guix/web.scm index 2236bfd621..e9c69cb0c0 100644 --- a/guix/web.scm +++ b/guix/web.scm @@ -141,20 +141,30 @@ 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)) +(define* (http-fetch uri #:key (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." +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>? "2.0.7" (version)) (if (defined? 'http-get*) - (http-get* uri #:decode-body? text?) ; 2.0.7 - (http-get uri #:decode-body? text?)) ; 2.0.5- - (http-get uri #:streaming? #t))) ; 2.0.9+ + (http-get* uri #:decode-body? text? + #:port port) ; 2.0.7 + (http-get uri #:decode-body? text? + #:port port)) ; 2.0.5- + (http-get uri #:streaming? #t + #:port port))) ; 2.0.9+ ((code) (response-code resp))) (case code @@ -182,7 +192,8 @@ textual. Follow any HTTP redirection." ((301 ; moved permanently 302) ; found (redirection) (let ((uri (response-location resp))) - (format #t "following redirection to `~a'...~%" + (close-port port) + (format #t (_ "following redirection to `~a'...~%") (uri->string uri)) (loop uri))) (else -- cgit v1.2.3