;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Sou Bunnbu <iyzsong@gmail.com>
;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com>
+;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
;;; This file is part of GNU Guix.
;;;
progress-reporter?
call-with-progress-reporter
+ start-progress-reporter!
+ stop-progress-reporter!
+ progress-reporter-report!
+
progress-reporter/silent
progress-reporter/file
+ progress-reporter/bar
+ progress-reporter/trace
+ progress-report-port
+ display-download-progress
+ erase-current-line
+ progress-bar
byte-count->string
current-terminal-columns
(($ <progress-reporter> start report stop)
(dynamic-wind start (lambda () (proc report)) stop))))
+(define (start-progress-reporter! reporter)
+ "Low-level procedure to start REPORTER."
+ (match reporter
+ (($ <progress-reporter> start report stop)
+ (start))))
+
+(define (progress-reporter-report! reporter . args)
+ "Low-level procedure to lead REPORTER to emit a report."
+ (match reporter
+ (($ <progress-reporter> start report stop)
+ (apply report args))))
+
+(define (stop-progress-reporter! reporter)
+ "Low-level procedure to stop REPORTER."
+ (match reporter
+ (($ <progress-reporter> start report stop)
+ (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."
(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))
+ (let* ((bar-width (max 3 (- bar-width 2)))
+ (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 (erase-current-line port)
+ "Write an ANSI erase-current-line sequence to PORT to erase the whole line and
+move the cursor to the beginning of the line."
+ (display "\r\x1b[K" port))
+
+(define* (display-download-progress file size
+ #:key
+ start-time (transferred 0)
+ (log-port (current-error-port)))
+ "Write the progress report to LOG-PORT. Use START-TIME (a SRFI-19 time
+object) and TRANSFERRED (a total number of bytes) to determine the
+throughput."
+ (define elapsed
+ (duration->seconds
+ (time-difference (current-time (time-type start-time))
+ start-time)))
+
+ (if (and (number? size) (not (zero? size)))
+ (let* ((% (* 100.0 (/ transferred size)))
+ (throughput (/ transferred elapsed))
+ (left (format #f " ~a ~a" file
+ (byte-count->string size)))
+ (right (format #f "~a/s ~a ~a~6,1f%"
+ (byte-count->string throughput)
+ (seconds->string elapsed)
+ (progress-bar %) %)))
+ (erase-current-line log-port)
+ (display (string-pad-middle left right
+ (current-terminal-columns))
+ log-port)
+ (force-output log-port))
+ ;; If we don't know the total size, the last transfer will have a 0B
+ ;; size. Don't display it.
+ (unless (zero? transferred)
+ (let* ((throughput (/ transferred elapsed))
+ (left (format #f " ~a" file))
+ (right (format #f "~a/s ~a | ~a transferred"
+ (byte-count->string throughput)
+ (seconds->string elapsed)
+ (byte-count->string transferred))))
+ (erase-current-line log-port)
+ (display (string-pad-middle left right
+ (current-terminal-columns))
+ log-port)
+ (force-output log-port)))))
+
+(define %progress-interval
+ ;; Default interval between subsequent outputs for rate-limited displays.
+ (make-time time-duration 200000000 0))
+
(define* (progress-reporter/file file size
#:optional (log-port (current-output-port))
#:key (abbreviation basename))
(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))))
+ (display-download-progress (abbreviation file) size
+ #:start-time start-time
+ #:transferred transferred
+ #:log-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))))
+ (let ((rate-limited-render (rate-limited render %progress-interval)))
(lambda (value)
(set! transferred value)
(rate-limited-render))))
;; Don't miss the last report.
(stop render))))
+(define* (progress-reporter/bar total
+ #:optional
+ (prefix "")
+ (port (current-error-port)))
+ "Return a reporter that shows a progress bar every time one of the TOTAL
+tasks is performed. Write PREFIX at the beginning of the line."
+ (define done 0)
+
+ (define (report-progress)
+ (set! done (+ 1 done))
+ (unless (> done total)
+ (let* ((ratio (* 100. (/ done total))))
+ (erase-current-line port)
+ (if (string-null? prefix)
+ (display (progress-bar ratio (current-terminal-columns)) port)
+ (let ((width (- (current-terminal-columns)
+ (string-length prefix) 3)))
+ (display prefix port)
+ (display " " port)
+ (display (progress-bar ratio width) port)))
+ (force-output port))))
+
+ (progress-reporter
+ (start (lambda ()
+ (set! done 0)))
+ (report report-progress)
+ (stop (lambda ()
+ (erase-current-line port)
+ (unless (string-null? prefix)
+ (display prefix port)
+ (newline port))
+ (force-output port)))))
+
+(define* (progress-reporter/trace file url size
+ #:optional (log-port (current-output-port)))
+ "Like 'progress-reporter/file', but instead of returning human-readable
+progress reports, write \"build trace\" lines to be processed elsewhere."
+ (define total 0) ;bytes transferred
+
+ (define (report-progress transferred)
+ (define message
+ (format #f "@ download-progress ~a ~a ~a ~a~%"
+ file url (or size "-") transferred))
+
+ (display message log-port) ;should be atomic
+ (flush-output-port log-port))
+
+ (progress-reporter
+ (start (lambda ()
+ (set! total 0)
+ (display (format #f "@ download-started ~a ~a ~a~%"
+ file url (or size "-"))
+ log-port)))
+ (report (let ((report (rate-limited report-progress %progress-interval)))
+ (lambda (transferred)
+ (set! total transferred)
+ (report transferred))))
+ (stop (lambda ()
+ (let ((size (or size total)))
+ (report-progress size)
+ (display (format #f "@ download-succeeded ~a ~a ~a~%"
+ file url size)
+ log-port))))))
+
;; TODO: replace '(@ (guix build utils) dump-port))'.
(define* (dump-port* in out
#:key (buffer-size 16384)
(put-bytevector out buffer 0 bytes)
(report total)
(loop total (get-bytevector-n! in buffer 0 buffer-size))))))))
+
+(define (progress-report-port reporter port)
+ "Return a port that continuously reports the bytes read from PORT using
+REPORTER, which should be a <progress-reporter> object."
+ (match reporter
+ (($ <progress-reporter> start report stop)
+ (let* ((total 0)
+ (read! (lambda (bv start count)
+ (let ((n (match (get-bytevector-n! port bv start count)
+ ((? eof-object?) 0)
+ (x x))))
+ (set! total (+ total n))
+ (report total)
+ n))))
+ (start)
+ (make-custom-binary-input-port "progress-port-proc"
+ read! #f #f
+ (lambda ()
+ ;; XXX: Kludge! When used through
+ ;; 'decompressed-port', this port ends
+ ;; up being closed twice: once in a
+ ;; child process early on, and at the
+ ;; end in the parent process. Ignore
+ ;; the early close so we don't output
+ ;; a spurious "download-succeeded"
+ ;; trace.
+ (unless (zero? total)
+ (stop))
+ (close-port port)))))))
+
HCoop / jackhill / guix / guix.git / blobdiff