rekahsoft
/
guix
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Add (guix progress). 

Among other things, this removes (guix utils), (guix ui), (guix config),
etc. from the closure of (guix build download), as was the case since
798648515b.

* guix/utils.scm (<progress-reporter>, call-with-progress-reporter):
Move to...
* guix/progress.scm: ... here.  New file.
* Makefile.am (MODULES): Add it.
* guix/build/download.scm (current-terminal-columns)
(nearest-exact-integer, duration->seconds, seconds->string)
(byte-count->string, progress-bar, string-pad-middle)
(rate-limited, progress-reporter/file, dump-port*)
(time-monotonic): Move to progress.scm.
* guix/scripts/download.scm: Adjust accordingly.
* guix/scripts/substitute.scm: Likewise.
This commit is contained in:
Ludovic Courtès 2017-10-16 23:16:39 +02:00
parent 347fa4aebf
commit 8c3488259e
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
6 changed files with 236 additions and 197 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Makefile.am
View File

@ -47,6 +47,7 @@ MODULES = \
guix/hash.scm \
guix/pk-crypto.scm \
guix/pki.scm \
guix/progress.scm \
guix/combinators.scm \
guix/memoization.scm \
guix/utils.scm \

167
guix/build/download.scm
View File

@ -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)
@ -46,8 +45,6 @@
maybe-expand-mirrors
url-fetch
byte-count->string
current-terminal-columns
progress-reporter/file
uri-abbreviation
nar-uri-abbreviation
store-path-abbreviation))
@ -62,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."
@ -143,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."

228
guix/progress.scm Normal file
View File

@ -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))))))))

4
guix/scripts/download.scm
View File

@ -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)

5
guix/scripts/substitute.scm
View File

@ -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)

28
guix/utils.scm
View File

@ -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))
;;;
@ -757,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: