diff options
Diffstat (limited to 'guix/build/download.scm')
| -rw-r--r-- | guix/build/download.scm | 216 |
1 files changed, 24 insertions, 192 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm index 9490f48055..61c9c6d3f1 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -1,7 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> -;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com> ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> ;;; ;;; This file is part of GNU Guix. @@ -27,7 +26,7 @@ #:use-module (guix base64) #:use-module (guix ftp-client) #:use-module (guix build utils) - #:use-module (guix utils) + #:use-module (guix progress) #:use-module (rnrs io ports) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) @@ -39,14 +38,13 @@ #:use-module (ice-9 format) #:export (open-socket-for-uri open-connection-for-uri + http-fetch %x509-certificate-directory close-connection resolve-uri-reference maybe-expand-mirrors url-fetch byte-count->string - current-terminal-columns - progress-reporter/file uri-abbreviation nar-uri-abbreviation store-path-abbreviation)) @@ -61,69 +59,6 @@ ;; Size of the HTTP receive buffer. 65536) -(define current-terminal-columns - ;; Number of columns of the terminal. - (make-parameter 80)) - -(define (nearest-exact-integer x) - "Given a real number X, return the nearest exact integer, with ties going to -the nearest exact even integer." - (inexact->exact (round x))) - -(define (duration->seconds duration) - "Return the number of seconds represented by DURATION, a 'time-duration' -object, as an inexact number." - (+ (time-second duration) - (/ (time-nanosecond duration) 1e9))) - -(define (seconds->string duration) - "Given DURATION in seconds, return a string representing it in 'mm:ss' or -'hh:mm:ss' format, as needed." - (if (not (number? duration)) - "00:00" - (let* ((total-seconds (nearest-exact-integer duration)) - (extra-seconds (modulo total-seconds 3600)) - (num-hours (quotient total-seconds 3600)) - (hours (and (positive? num-hours) num-hours)) - (mins (quotient extra-seconds 60)) - (secs (modulo extra-seconds 60))) - (format #f "~@[~2,'0d:~]~2,'0d:~2,'0d" hours mins secs)))) - -(define (byte-count->string size) - "Given SIZE in bytes, return a string representing it in a human-readable -way." - (let ((KiB 1024.) - (MiB (expt 1024. 2)) - (GiB (expt 1024. 3)) - (TiB (expt 1024. 4))) - (cond - ((< size KiB) (format #f "~dB" (nearest-exact-integer size))) - ((< size MiB) (format #f "~dKiB" (nearest-exact-integer (/ size KiB)))) - ((< size GiB) (format #f "~,1fMiB" (/ size MiB))) - ((< size TiB) (format #f "~,2fGiB" (/ size GiB))) - (else (format #f "~,3fTiB" (/ size TiB)))))) - -(define* (progress-bar % #:optional (bar-width 20)) - "Return % as a string representing an ASCII-art progress bar. The total -width of the bar is BAR-WIDTH." - (let* ((fraction (/ % 100)) - (filled (inexact->exact (floor (* fraction bar-width)))) - (empty (- bar-width filled))) - (format #f "[~a~a]" - (make-string filled #\#) - (make-string empty #\space)))) - -(define (string-pad-middle left right len) - "Combine LEFT and RIGHT with enough padding in the middle so that the -resulting string has length at least LEN (it may overflow). If the string -does not overflow, the last char in RIGHT will be flush with the LEN -column." - (let* ((total-used (+ (string-length left) - (string-length right))) - (num-spaces (max 1 (- len total-used))) - (padding (make-string num-spaces #\space))) - (string-append left padding right))) - (define* (ellipsis #:optional (port (current-output-port))) "Make a rough guess at whether Unicode's HORIZONTAL ELLIPSIS can be written in PORT's encoding, and return either that or ASCII dots." @@ -142,105 +77,6 @@ Otherwise return STORE-PATH." (string-drop base 32))) store-path)) -(cond-expand - (guile-2.2 - ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and - ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it. - (define time-monotonic time-tai)) - (else #t)) - - -;; TODO: replace '(@ (guix build utils) dump-port))'. -(define* (dump-port* in out - #:key (buffer-size 16384) - (reporter (make-progress-reporter noop noop noop))) - "Read as much data as possible from IN and write it to OUT, using chunks of -BUFFER-SIZE bytes. After each successful transfer of BUFFER-SIZE bytes or -less, report the total number of bytes transferred to the REPORTER, which -should be a <progress-reporter> object." - (define buffer - (make-bytevector buffer-size)) - - (call-with-progress-reporter reporter - (lambda (report) - (let loop ((total 0) - (bytes (get-bytevector-n! in buffer 0 buffer-size))) - (or (eof-object? bytes) - (let ((total (+ total bytes))) - (put-bytevector out buffer 0 bytes) - (report total) - (loop total (get-bytevector-n! in buffer 0 buffer-size)))))))) - -(define (rate-limited proc interval) - "Return a procedure that will forward the invocation to PROC when the time -elapsed since the previous forwarded invocation is greater or equal to -INTERVAL (a time-duration object), otherwise does nothing and returns #f." - (let ((previous-at #f)) - (lambda args - (let* ((now (current-time time-monotonic)) - (forward-invocation (lambda () - (set! previous-at now) - (apply proc args)))) - (if previous-at - (let ((elapsed (time-difference now previous-at))) - (if (time>=? elapsed interval) - (forward-invocation) - #f)) - (forward-invocation)))))) - -(define* (progress-reporter/file file size - #:optional (log-port (current-output-port)) - #:key (abbreviation basename)) - "Return a <progress-reporter> object to show the progress of FILE's download, -which is SIZE bytes long. The progress report is written to LOG-PORT, with -ABBREVIATION used to shorten FILE for display." - (let ((start-time (current-time time-monotonic)) - (transferred 0)) - (define (render) - "Write the progress report to LOG-PORT." - (define elapsed - (duration->seconds - (time-difference (current-time time-monotonic) start-time))) - (if (number? size) - (let* ((% (* 100.0 (/ transferred size))) - (throughput (/ transferred elapsed)) - (left (format #f " ~a ~a" - (abbreviation file) - (byte-count->string size))) - (right (format #f "~a/s ~a ~a~6,1f%" - (byte-count->string throughput) - (seconds->string elapsed) - (progress-bar %) %))) - (display "\r\x1b[K" log-port) - (display (string-pad-middle left right - (current-terminal-columns)) - log-port) - (flush-output-port log-port)) - (let* ((throughput (/ transferred elapsed)) - (left (format #f " ~a" - (abbreviation file))) - (right (format #f "~a/s ~a | ~a transferred" - (byte-count->string throughput) - (seconds->string elapsed) - (byte-count->string transferred)))) - (display "\r\x1b[K" log-port) - (display (string-pad-middle left right - (current-terminal-columns)) - log-port) - (flush-output-port log-port)))) - - (progress-reporter - (start render) - ;; Report the progress every 300ms or longer. - (report - (let ((rate-limited-render - (rate-limited render (make-time time-monotonic 300000000 0)))) - (lambda (value) - (set! transferred value) - (rate-limited-render)))) - ;; Don't miss the last report. - (stop render)))) - (define* (uri-abbreviation uri #:optional (max-length 42)) "If URI's string representation is larger than MAX-LENGTH, return an abbreviation of URI showing the scheme, host, and basename of the file." @@ -745,11 +581,11 @@ Return the resulting target URI." #:query (uri-query ref) #:fragment (uri-fragment ref))))) -(define* (http-fetch uri file #:key timeout (verify-certificate? #t)) - "Fetch data from URI and write it to FILE; when TIMEOUT is true, bail out if -the connection could not be established in less than TIMEOUT seconds. Return -FILE on success. When VERIFY-CERTIFICATE? is true, verify HTTPS -certificates; otherwise simply ignore them." +(define* (http-fetch uri #:key timeout (verify-certificate? #t)) + "Return an input port containing the data at URI, and the expected number of +bytes available or #f. When TIMEOUT is true, bail out if the connection could +not be established in less than TIMEOUT seconds. When VERIFY-CERTIFICATE? is +true, verify HTTPS certificates; otherwise simply ignore them." (define headers `(;; Some web sites, such as http://dist.schmorp.de, would block you if @@ -774,28 +610,15 @@ certificates; otherwise simply ignore them." #:timeout timeout #:verify-certificate? verify-certificate?)) - ((resp bv-or-port) + ((resp port) (http-get uri #:port connection #:decode-body? #f #:streaming? #t #:headers headers)) ((code) - (response-code resp)) - ((size) - (response-content-length resp))) + (response-code resp))) (case code ((200) ; OK - (begin - (call-with-output-file file - (lambda (p) - (if (port? bv-or-port) - (begin - (dump-port* bv-or-port p - #:buffer-size %http-receive-buffer-size - #:reporter (progress-reporter/file - (uri-abbreviation uri) size)) - (newline)) - (put-bytevector p bv-or-port)))) - file)) + (values port (response-content-length resp))) ((301 ; moved permanently 302 ; found (redirection) 303 ; see other @@ -805,7 +628,7 @@ certificates; otherwise simply ignore them." (format #t "following redirection to `~a'...~%" (uri->string uri)) (close connection) - (http-fetch uri file + (http-fetch uri #:timeout timeout #:verify-certificate? verify-certificate?))) (else @@ -876,10 +699,19 @@ otherwise simply ignore them." file (uri->string uri)) (case (uri-scheme uri) ((http https) - (false-if-exception* (http-fetch uri file - #:verify-certificate? - verify-certificate? - #:timeout timeout))) + (false-if-exception* + (let-values (((port size) + (http-fetch uri + #:verify-certificate? verify-certificate? + #:timeout timeout))) + (call-with-output-file file + (lambda (output) + (dump-port* port output + #:buffer-size %http-receive-buffer-size + #:reporter (progress-reporter/file + (uri-abbreviation uri) size)) + (newline))) + #t))) ((ftp) (false-if-exception* (ftp-fetch uri file #:timeout timeout))) |