diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build-system/r.scm | 2 | ||||
| -rw-r--r-- | guix/build/download-nar.scm | 125 | ||||
| -rw-r--r-- | guix/build/download.scm | 216 | ||||
| -rw-r--r-- | guix/cvs-download.scm | 38 | ||||
| -rw-r--r-- | guix/git-download.scm | 37 | ||||
| -rw-r--r-- | guix/hg-download.scm | 36 | ||||
| -rw-r--r-- | guix/import/cran.scm | 8 | ||||
| -rw-r--r-- | guix/progress.scm | 228 | ||||
| -rw-r--r-- | guix/scripts/download.scm | 4 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 16 | ||||
| -rw-r--r-- | guix/utils.scm | 30 |
11 files changed, 482 insertions, 258 deletions
diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index c649036210..2c8a89f8de 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -50,7 +50,7 @@ available via the first URI, the second URI points to the archived version." (define (bioconductor-uri name version) "Return a URI string for the R package archive on Bioconductor for the release corresponding to NAME and VERSION." - (string-append "http://bioconductor.org/packages/release/bioc/src/contrib/" + (string-append "https://bioconductor.org/packages/release/bioc/src/contrib/" name "_" version ".tar.gz")) (define %r-build-system-modules diff --git a/guix/build/download-nar.scm b/guix/build/download-nar.scm new file mode 100644 index 0000000000..13f01fb1e8 --- /dev/null +++ b/guix/build/download-nar.scm @@ -0,0 +1,125 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build download-nar) + #:use-module (guix build download) + #:use-module (guix build utils) + #:use-module (guix serialization) + #:use-module (guix zlib) + #:use-module (guix progress) + #:use-module (web uri) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:export (download-nar)) + +;;; Commentary: +;;; +;;; Download a normalized archive or "nar", similar to what 'guix substitute' +;;; does. The intent here is to use substitute servers as content-addressed +;;; mirrors of VCS checkouts. This is mostly useful for users who have +;;; disabled substitutes. +;;; +;;; Code: + +(define (urls-for-item item) + "Return the fallback nar URL for ITEM--e.g., +\"/gnu/store/cabbag3…-foo-1.2-checkout\"." + ;; Here we hard-code nar URLs without checking narinfos. That's probably OK + ;; though. + ;; TODO: Use HTTPS? The downside is the extra dependency. + (let ((bases '("http://mirror.hydra.gnu.org/guix" + "http://berlin.guixsd.org")) + (item (basename item))) + (append (map (cut string-append <> "/nar/gzip/" item) bases) + (map (cut string-append <> "/nar/" item) bases)))) + +(define (restore-gzipped-nar port item size) + "Restore the gzipped nar read from PORT, of SIZE bytes (compressed), to +ITEM." + ;; Since PORT is typically a non-file port (for instance because 'http-get' + ;; returns a delimited port), create a child process so we're back to a file + ;; port that can be passed to 'call-with-gzip-input-port'. + (match (pipe) + ((input . output) + (match (primitive-fork) + (0 + (dynamic-wind + (const #t) + (lambda () + (close-port output) + (close-port port) + (catch #t + (lambda () + (call-with-gzip-input-port input + (cut restore-file <> item))) + (lambda (key . args) + (print-exception (current-error-port) + (stack-ref (make-stack #t) 1) + key args) + (primitive-exit 1)))) + (lambda () + (primitive-exit 0)))) + (child + (close-port input) + (dump-port* port output + #:reporter (progress-reporter/file item size + #:abbreviation + store-path-abbreviation)) + (close-port output) + (newline) + (match (waitpid child) + ((_ . status) + (unless (zero? status) + (error "nar decompression failed" status))))))))) + +(define (download-nar item) + "Download and extract the normalized archive for ITEM. Return #t on +success, #f otherwise." + ;; Let progress reports go through. + (setvbuf (current-error-port) _IONBF) + (setvbuf (current-output-port) _IONBF) + + (let loop ((urls (urls-for-item item))) + (match urls + ((url rest ...) + (format #t "Trying content-addressed mirror at ~a...~%" + (uri-host (string->uri url))) + (let-values (((port size) + (catch #t + (lambda () + (http-fetch (string->uri url))) + (lambda args + (values #f #f))))) + (if (not port) + (loop rest) + (begin + (if size + (format #t "Downloading from ~a (~,2h MiB)...~%" url + (/ size (expt 2 20.))) + (format #t "Downloading from ~a...~%" url)) + (if (string-contains url "/gzip") + (restore-gzipped-nar port item size) + (begin + ;; FIXME: Add progress report. + (restore-file port item) + (close-port port))) + #t)))) + (() + #f)))) 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))) diff --git a/guix/cvs-download.scm b/guix/cvs-download.scm index 85744c5b55..8b46f8ef8c 100644 --- a/guix/cvs-download.scm +++ b/guix/cvs-download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; @@ -23,6 +23,7 @@ #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix monads) + #:use-module (guix modules) #:use-module (guix packages) #:use-module (ice-9 match) #:export (cvs-reference @@ -59,16 +60,35 @@ "Return a fixed-output derivation that fetches REF, a <cvs-reference> object. The output is expected to have recursive hash HASH of type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." + (define zlib + (module-ref (resolve-interface '(gnu packages compression)) 'zlib)) + + (define config.scm + (scheme-file "config.scm" + #~(begin + (define-module (guix config) + #:export (%libz)) + + (define %libz + #+(file-append zlib "/lib/libz"))))) + + (define modules + (cons `((guix config) => ,config.scm) + (delete '(guix config) + (source-module-closure '((guix build cvs) + (guix build download-nar)))))) (define build - (with-imported-modules '((guix build cvs) - (guix build utils)) + (with-imported-modules modules #~(begin - (use-modules (guix build cvs)) - (cvs-fetch '#$(cvs-reference-root-directory ref) - '#$(cvs-reference-module ref) - '#$(cvs-reference-revision ref) - #$output - #:cvs-command (string-append #+cvs "/bin/cvs"))))) + (use-modules (guix build cvs) + (guix build download-nar)) + + (or (cvs-fetch '#$(cvs-reference-root-directory ref) + '#$(cvs-reference-module ref) + '#$(cvs-reference-revision ref) + #$output + #:cvs-command (string-append #+cvs "/bin/cvs")) + (download-nar #$output))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "cvs-checkout") build diff --git a/guix/git-download.scm b/guix/git-download.scm index 7397cbe7f5..731e549b38 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -25,6 +25,7 @@ #:use-module (guix monads) #:use-module (guix records) #:use-module (guix packages) + #:use-module (guix modules) #:autoload (guix build-system gnu) (standard-packages) #:use-module (ice-9 match) #:use-module (ice-9 popen) @@ -77,12 +78,31 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (standard-packages) '())) + (define zlib + (module-ref (resolve-interface '(gnu packages compression)) 'zlib)) + + (define config.scm + (scheme-file "config.scm" + #~(begin + (define-module (guix config) + #:export (%libz)) + + (define %libz + #+(file-append zlib "/lib/libz"))))) + + (define modules + (cons `((guix config) => ,config.scm) + (delete '(guix config) + (source-module-closure '((guix build git) + (guix build utils) + (guix build download-nar)))))) + (define build - (with-imported-modules '((guix build git) - (guix build utils)) + (with-imported-modules modules #~(begin (use-modules (guix build git) (guix build utils) + (guix build download-nar) (ice-9 match)) ;; The 'git submodule' commands expects Coreutils, sed, @@ -92,12 +112,13 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (((names dirs) ...) dirs))) - (git-fetch (getenv "git url") (getenv "git commit") - #$output - #:recursive? (call-with-input-string - (getenv "git recursive?") - read) - #:git-command (string-append #+git "/bin/git"))))) + (or (git-fetch (getenv "git url") (getenv "git commit") + #$output + #:recursive? (call-with-input-string + (getenv "git recursive?") + read) + #:git-command (string-append #+git "/bin/git")) + (download-nar #$output))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "git-checkout") build diff --git a/guix/hg-download.scm b/guix/hg-download.scm index 8420980905..6b25b87b6b 100644 --- a/guix/hg-download.scm +++ b/guix/hg-download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. @@ -22,6 +22,7 @@ #:use-module (guix store) #:use-module (guix monads) #:use-module (guix records) + #:use-module (guix modules) #:use-module (guix packages) #:autoload (guix build-system gnu) (standard-packages) #:use-module (ice-9 match) @@ -59,18 +60,35 @@ "Return a fixed-output derivation that fetches REF, a <hg-reference> object. The output is expected to have recursive hash HASH of type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." + (define zlib + (module-ref (resolve-interface '(gnu packages compression)) 'zlib)) + + (define config.scm + (scheme-file "config.scm" + #~(begin + (define-module (guix config) + #:export (%libz)) + + (define %libz + #+(file-append zlib "/lib/libz"))))) + + (define modules + (cons `((guix config) => ,config.scm) + (delete '(guix config) + (source-module-closure '((guix build hg) + (guix build download-nar)))))) + (define build - (with-imported-modules '((guix build hg) - (guix build utils)) + (with-imported-modules modules #~(begin (use-modules (guix build hg) - (guix build utils) - (ice-9 match)) + (guix build download-nar)) - (hg-fetch '#$(hg-reference-url ref) - '#$(hg-reference-changeset ref) - #$output - #:hg-command (string-append #+hg "/bin/hg"))))) + (or (hg-fetch '#$(hg-reference-url ref) + '#$(hg-reference-changeset ref) + #$output + #:hg-command (string-append #+hg "/bin/hg")) + (download-nar #$output))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "hg-checkout") build diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 056a7dcc7c..9b08ebfb63 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -126,7 +126,7 @@ package definition." `((,type (,'quasiquote ,(format-inputs package-inputs))))))) (define %cran-url "http://cran.r-project.org/web/packages/") -(define %bioconductor-url "http://bioconductor.org/packages/") +(define %bioconductor-url "https://bioconductor.org/packages/") ;; The latest Bioconductor release is 3.5. Bioconductor packages should be ;; updated together. @@ -446,7 +446,7 @@ dependencies." (define (bioconductor-package? package) "Return true if PACKAGE is an R package from Bioconductor." (let ((predicate (lambda (uri) - (and (string-prefix? "http://bioconductor.org" uri) + (and (string-prefix? "https://bioconductor.org" uri) ;; Data packages are neither listed in SVN nor on ;; the Github mirror, so we have to exclude them ;; from the set of bioconductor packages that can be @@ -465,7 +465,7 @@ dependencies." (define (bioconductor-data-package? package) "Return true if PACKAGE is an R data package from Bioconductor." (let ((predicate (lambda (uri) - (and (string-prefix? "http://bioconductor.org" uri) + (and (string-prefix? "https://bioconductor.org" uri) (string-contains uri "/data/annotation/"))))) (and (string-prefix? "r-" (package-name package)) (match (and=> (package-source package) origin-uri) @@ -478,7 +478,7 @@ dependencies." (define (bioconductor-experiment-package? package) "Return true if PACKAGE is an R experiment package from Bioconductor." (let ((predicate (lambda (uri) - (and (string-prefix? "http://bioconductor.org" uri) + (and (string-prefix? "https://bioconductor.org" uri) (string-contains uri "/data/experiment/"))))) (and (string-prefix? "r-" (package-name package)) (match (and=> (package-source package) origin-uri) diff --git a/guix/progress.scm b/guix/progress.scm new file mode 100644 index 0000000000..beca2c22a6 --- /dev/null +++ b/guix/progress.scm @@ -0,0 +1,228 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Sou Bunnbu <iyzsong@gmail.com> +;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix progress) + #:use-module (guix records) + #:use-module (srfi srfi-19) + #:use-module (rnrs io ports) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:export (<progress-reporter> + progress-reporter + make-progress-reporter + progress-reporter? + call-with-progress-reporter + + progress-reporter/silent + progress-reporter/file + + byte-count->string + current-terminal-columns + + dump-port*)) + +;;; Commentary: +;;; +;;; Helper to write progress report code for downloads, etc. +;;; +;;; Code: + +(define-record-type* <progress-reporter> + progress-reporter make-progress-reporter progress-reporter? + (start progress-reporter-start) ; thunk + (report progress-reporter-report) ; procedure + (stop progress-reporter-stop)) ; thunk + +(define (call-with-progress-reporter reporter proc) + "Start REPORTER for progress reporting, and call @code{(@var{proc} report)} +with the resulting report procedure. When @var{proc} returns, the REPORTER is +stopped." + (match reporter + (($ <progress-reporter> start report stop) + (dynamic-wind start (lambda () (proc report)) stop)))) + +(define progress-reporter/silent + (make-progress-reporter noop noop noop)) + + +;;; +;;; File download progress report. +;;; + +(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)) + +(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 (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 (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 current-terminal-columns + ;; Number of columns of the terminal. + (make-parameter 80)) + +(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* (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) + (force-output 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) + (force-output 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)))) + +;; TODO: replace '(@ (guix build utils) dump-port))'. +(define* (dump-port* in out + #:key (buffer-size 16384) + (reporter progress-reporter/silent)) + "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)))))))) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 8225f82bb9..1b99bc62cf 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -25,7 +25,9 @@ #:use-module (guix base32) #:use-module ((guix download) #:hide (url-fetch)) #:use-module ((guix build download) - #:select (url-fetch current-terminal-columns)) + #:select (url-fetch)) + #:use-module ((guix progress) + #:select (current-terminal-columns)) #:use-module ((guix build syscalls) #:select (terminal-columns)) #:use-module (web uri) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 921a7c6790..1fbeed71e8 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -33,13 +33,12 @@ #:use-module (guix pki) #:use-module ((guix build utils) #:select (mkdir-p dump-port)) #:use-module ((guix build download) - #:select (current-terminal-columns - progress-reporter/file - uri-abbreviation nar-uri-abbreviation + #:select (uri-abbreviation nar-uri-abbreviation (open-connection-for-uri . guix:open-connection-for-uri) close-connection store-path-abbreviation byte-count->string)) + #:use-module (guix progress) #:use-module ((guix build syscalls) #:select (set-thread-name)) #:use-module (ice-9 rdelim) @@ -956,19 +955,22 @@ DESTINATION as a nar file. Verify the substitute against ACL." #:abbreviation nar-uri-abbreviation))) (progress-report-port reporter raw))) ((input pids) + ;; NOTE: This 'progress' port of current process will be + ;; closed here, while the child process doing the + ;; reporting will close it upon exit. (decompressed-port (and=> (narinfo-compression narinfo) string->symbol) progress))) ;; Unpack the Nar at INPUT into DESTINATION. (restore-file input destination) (close-port input) - (close-port progress) + + ;; Wait for the reporter to finish. + (every (compose zero? cdr waitpid) pids) ;; Skip a line after what 'progress-reporter/file' printed, and another ;; one to visually separate substitutions. - (display "\n\n" (current-error-port)) - - (every (compose zero? cdr waitpid) pids)))) + (display "\n\n" (current-error-port))))) ;;; diff --git a/guix/utils.scm b/guix/utils.scm index de4aa65319..eb1ec29b32 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -33,7 +33,6 @@ #:autoload (rnrs io ports) (make-custom-binary-input-port) #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!)) #:use-module (guix memoization) - #:use-module (guix records) #:use-module ((guix build utils) #:select (dump-port mkdir-p)) #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync)) #:use-module (ice-9 format) @@ -95,13 +94,7 @@ call-with-decompressed-port compressed-output-port call-with-compressed-output-port - canonical-newline-port - - <progress-reporter> - progress-reporter - make-progress-reporter - progress-reporter? - call-with-progress-reporter)) + canonical-newline-port)) ;;; @@ -153,9 +146,11 @@ buffered data is lost." (close-port in) (dump-port input out)) (lambda () + (close-port input) (false-if-exception (close out)) (primitive-_exit 0)))) (child + (close-port input) (close-port out) (loop in (cons child pids))))))))) @@ -755,25 +750,6 @@ a location object." (column . ,(location-column loc)) (filename . ,(location-file loc)))) - -;;; -;;; Progress reporter. -;;; - -(define-record-type* <progress-reporter> - progress-reporter make-progress-reporter progress-reporter? - (start progress-reporter-start) ; thunk - (report progress-reporter-report) ; procedure - (stop progress-reporter-stop)) ; thunk - -(define (call-with-progress-reporter reporter proc) - "Start REPORTER for progress reporting, and call @code{(@var{proc} report)} -with the resulting report procedure. When @var{proc} returns, the REPORTER is -stopped." - (match reporter - (($ <progress-reporter> start report stop) - (dynamic-wind start (lambda () (proc report)) stop)))) - ;;; Local Variables: ;;; eval: (put 'call-with-progress-reporter 'scheme-indent-function 1) ;;; End: |