summaryrefslogtreecommitdiff
path: root/guix/progress.scm
diff options
context:
space:
mode:
authorMarius Bakke <mbakke@fastmail.com>2017-10-22 20:12:52 +0200
committerMarius Bakke <mbakke@fastmail.com>2017-10-22 20:12:52 +0200
commit119a749db9c9847e0766860c17109b0f0b6bf349 (patch)
tree4cdbfcad285124c1abf7b3c1c94666cef55767ce /guix/progress.scm
parent530d9e1555e8d0125dde6893f5f70c7a1ebc2564 (diff)
parent25669275a1a570cc266128274cb27a22f6a3a318 (diff)
Merge branch 'master' into core-updates
Diffstat (limited to 'guix/progress.scm')
-rw-r--r--guix/progress.scm228
1 files changed, 228 insertions, 0 deletions
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))))))))