diff options
| -rw-r--r-- | guix/build/download.scm | 4 | ||||
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 48 |
2 files changed, 41 insertions, 11 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm index 53e6b2363c..dcce0bfc89 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -28,7 +28,9 @@ #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:use-module (ice-9 format) - #:export (url-fetch)) + #:export (url-fetch + progress-proc + uri-abbreviation)) ;;; Commentary: ;;; diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index ef3db77ee1..271a22541a 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -24,12 +24,15 @@ #:use-module (guix records) #:use-module (guix nar) #:use-module ((guix build utils) #:select (mkdir-p)) + #:use-module ((guix build download) + #:select (progress-proc uri-abbreviation)) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (ice-9 match) #:use-module (ice-9 threads) #:use-module (ice-9 format) #:use-module (ice-9 ftw) + #:use-module (ice-9 binary-ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) @@ -398,7 +401,8 @@ indefinitely." (cute write (time-second now) <>)))) (define (decompressed-port compression input) - "Return an input port where INPUT is decompressed according to COMPRESSION." + "Return an input port where INPUT is decompressed according to COMPRESSION, +along with a list of PIDs to wait for." (match compression ("none" (values input '())) ("bzip2" (filtered-port `(,%bzip2 "-dc") input)) @@ -406,6 +410,24 @@ indefinitely." ("gzip" (filtered-port `(,%gzip "-dc") input)) (else (error "unsupported compression scheme" compression)))) +(define (progress-report-port report-progress port) + "Return a port that calls REPORT-PROGRESS every time something is read from +PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by +`progress-proc'." + (define total 0) + (define (read! bv start count) + (let ((n (match (get-bytevector-n! port bv start count) + ((? eof-object?) 0) + (x x)))) + (set! total (+ total n)) + (report-progress total (const n)) + ;; XXX: We're not in control, so we always return anyway. + n)) + + (make-custom-binary-input-port "progress-port-proc" + read! #f #f + (cut close-port port))) + (define %cache-url (or (getenv "GUIX_BINARY_SUBSTITUTE_URL") "http://hydra.gnu.org")) @@ -487,19 +509,25 @@ indefinitely." ;; Tell the daemon what the expected hash of the Nar itself is. (format #t "~a~%" (narinfo-hash narinfo)) + (format (current-error-port) "downloading `~a' from `~a'...~%" + store-path (uri->string uri)) (let*-values (((raw download-size) + ;; Note that Hydra currently generates Nars on the fly + ;; and doesn't specify a Content-Length, so + ;; DOWNLOAD-SIZE is #f in practice. (fetch uri #:buffered? #f #:timeout? #f)) + ((progress) + (let* ((comp (narinfo-compression narinfo)) + (dl-size (or download-size + (and (equal? comp "none") + (narinfo-size narinfo)))) + (progress (progress-proc (uri-abbreviation uri) + dl-size + (current-error-port)))) + (progress-report-port progress raw))) ((input pids) (decompressed-port (narinfo-compression narinfo) - raw))) - ;; Note that Hydra currently generates Nars on the fly and doesn't - ;; specify a Content-Length, so DOWNLOAD-SIZE is #f in practice. - (format (current-error-port) - (_ "downloading `~a' from `~a'~:[~*~; (~,1f KiB)~]...~%") - store-path (uri->string uri) - download-size - (and=> download-size (cut / <> 1024.0))) - + progress))) ;; Unpack the Nar at INPUT into DESTINATION. (restore-file input destination) (every (compose zero? cdr waitpid) pids)))) |