Commit | Line | Data |
---|---|---|
8c348825 LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2017 Sou Bunnbu <iyzsong@gmail.com> | |
3 | ;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com> | |
9acacb71 | 4 | ;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> |
0289dc14 | 5 | ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> |
8c348825 LC |
6 | ;;; |
7 | ;;; This file is part of GNU Guix. | |
8 | ;;; | |
9 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
10 | ;;; under the terms of the GNU General Public License as published by | |
11 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
12 | ;;; your option) any later version. | |
13 | ;;; | |
14 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
15 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | ;;; GNU General Public License for more details. | |
18 | ;;; | |
19 | ;;; You should have received a copy of the GNU General Public License | |
20 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
21 | ||
22 | (define-module (guix progress) | |
23 | #:use-module (guix records) | |
24 | #:use-module (srfi srfi-19) | |
25 | #:use-module (rnrs io ports) | |
26 | #:use-module (rnrs bytevectors) | |
27 | #:use-module (ice-9 format) | |
28 | #:use-module (ice-9 match) | |
29 | #:export (<progress-reporter> | |
30 | progress-reporter | |
31 | make-progress-reporter | |
32 | progress-reporter? | |
33 | call-with-progress-reporter | |
34 | ||
1fafa2f5 LC |
35 | start-progress-reporter! |
36 | stop-progress-reporter! | |
37 | progress-reporter-report! | |
38 | ||
8c348825 LC |
39 | progress-reporter/silent |
40 | progress-reporter/file | |
4cdb27af | 41 | progress-reporter/bar |
dc0f74e5 | 42 | progress-reporter/trace |
22f06a21 | 43 | progress-report-port |
8c348825 | 44 | |
fe65b559 | 45 | display-download-progress |
dc0f74e5 LC |
46 | erase-current-line |
47 | progress-bar | |
8c348825 LC |
48 | byte-count->string |
49 | current-terminal-columns | |
50 | ||
51 | dump-port*)) | |
52 | ||
53 | ;;; Commentary: | |
54 | ;;; | |
55 | ;;; Helper to write progress report code for downloads, etc. | |
56 | ;;; | |
57 | ;;; Code: | |
58 | ||
59 | (define-record-type* <progress-reporter> | |
60 | progress-reporter make-progress-reporter progress-reporter? | |
61 | (start progress-reporter-start) ; thunk | |
62 | (report progress-reporter-report) ; procedure | |
63 | (stop progress-reporter-stop)) ; thunk | |
64 | ||
65 | (define (call-with-progress-reporter reporter proc) | |
66 | "Start REPORTER for progress reporting, and call @code{(@var{proc} report)} | |
67 | with the resulting report procedure. When @var{proc} returns, the REPORTER is | |
68 | stopped." | |
69 | (match reporter | |
70 | (($ <progress-reporter> start report stop) | |
71 | (dynamic-wind start (lambda () (proc report)) stop)))) | |
72 | ||
1fafa2f5 LC |
73 | (define (start-progress-reporter! reporter) |
74 | "Low-level procedure to start REPORTER." | |
75 | (match reporter | |
76 | (($ <progress-reporter> start report stop) | |
77 | (start)))) | |
78 | ||
cfe19684 | 79 | (define (progress-reporter-report! reporter . args) |
1fafa2f5 LC |
80 | "Low-level procedure to lead REPORTER to emit a report." |
81 | (match reporter | |
82 | (($ <progress-reporter> start report stop) | |
cfe19684 | 83 | (apply report args)))) |
1fafa2f5 LC |
84 | |
85 | (define (stop-progress-reporter! reporter) | |
86 | "Low-level procedure to stop REPORTER." | |
87 | (match reporter | |
88 | (($ <progress-reporter> start report stop) | |
89 | (stop)))) | |
90 | ||
8c348825 LC |
91 | (define progress-reporter/silent |
92 | (make-progress-reporter noop noop noop)) | |
93 | ||
94 | \f | |
95 | ;;; | |
96 | ;;; File download progress report. | |
97 | ;;; | |
98 | ||
8c348825 LC |
99 | (define (nearest-exact-integer x) |
100 | "Given a real number X, return the nearest exact integer, with ties going to | |
101 | the nearest exact even integer." | |
102 | (inexact->exact (round x))) | |
103 | ||
104 | (define (duration->seconds duration) | |
105 | "Return the number of seconds represented by DURATION, a 'time-duration' | |
106 | object, as an inexact number." | |
107 | (+ (time-second duration) | |
108 | (/ (time-nanosecond duration) 1e9))) | |
109 | ||
110 | (define (seconds->string duration) | |
111 | "Given DURATION in seconds, return a string representing it in 'mm:ss' or | |
112 | 'hh:mm:ss' format, as needed." | |
113 | (if (not (number? duration)) | |
114 | "00:00" | |
115 | (let* ((total-seconds (nearest-exact-integer duration)) | |
116 | (extra-seconds (modulo total-seconds 3600)) | |
117 | (num-hours (quotient total-seconds 3600)) | |
118 | (hours (and (positive? num-hours) num-hours)) | |
119 | (mins (quotient extra-seconds 60)) | |
120 | (secs (modulo extra-seconds 60))) | |
121 | (format #f "~@[~2,'0d:~]~2,'0d:~2,'0d" hours mins secs)))) | |
122 | ||
123 | (define (byte-count->string size) | |
124 | "Given SIZE in bytes, return a string representing it in a human-readable | |
125 | way." | |
126 | (let ((KiB 1024.) | |
127 | (MiB (expt 1024. 2)) | |
128 | (GiB (expt 1024. 3)) | |
129 | (TiB (expt 1024. 4))) | |
130 | (cond | |
131 | ((< size KiB) (format #f "~dB" (nearest-exact-integer size))) | |
132 | ((< size MiB) (format #f "~dKiB" (nearest-exact-integer (/ size KiB)))) | |
133 | ((< size GiB) (format #f "~,1fMiB" (/ size MiB))) | |
134 | ((< size TiB) (format #f "~,2fGiB" (/ size GiB))) | |
135 | (else (format #f "~,3fTiB" (/ size TiB)))))) | |
136 | ||
137 | (define (string-pad-middle left right len) | |
138 | "Combine LEFT and RIGHT with enough padding in the middle so that the | |
139 | resulting string has length at least LEN (it may overflow). If the string | |
140 | does not overflow, the last char in RIGHT will be flush with the LEN | |
141 | column." | |
142 | (let* ((total-used (+ (string-length left) | |
143 | (string-length right))) | |
144 | (num-spaces (max 1 (- len total-used))) | |
145 | (padding (make-string num-spaces #\space))) | |
146 | (string-append left padding right))) | |
147 | ||
148 | (define (rate-limited proc interval) | |
149 | "Return a procedure that will forward the invocation to PROC when the time | |
150 | elapsed since the previous forwarded invocation is greater or equal to | |
151 | INTERVAL (a time-duration object), otherwise does nothing and returns #f." | |
152 | (let ((previous-at #f)) | |
153 | (lambda args | |
154 | (let* ((now (current-time time-monotonic)) | |
155 | (forward-invocation (lambda () | |
156 | (set! previous-at now) | |
157 | (apply proc args)))) | |
158 | (if previous-at | |
159 | (let ((elapsed (time-difference now previous-at))) | |
160 | (if (time>=? elapsed interval) | |
161 | (forward-invocation) | |
162 | #f)) | |
163 | (forward-invocation)))))) | |
164 | ||
165 | (define current-terminal-columns | |
166 | ;; Number of columns of the terminal. | |
167 | (make-parameter 80)) | |
168 | ||
169 | (define* (progress-bar % #:optional (bar-width 20)) | |
170 | "Return % as a string representing an ASCII-art progress bar. The total | |
171 | width of the bar is BAR-WIDTH." | |
5ed534cc LC |
172 | (let* ((bar-width (max 3 (- bar-width 2))) |
173 | (fraction (/ % 100)) | |
8c348825 LC |
174 | (filled (inexact->exact (floor (* fraction bar-width)))) |
175 | (empty (- bar-width filled))) | |
176 | (format #f "[~a~a]" | |
177 | (make-string filled #\#) | |
178 | (make-string empty #\space)))) | |
179 | ||
3e0a4297 LC |
180 | (define (erase-current-line port) |
181 | "Write an ANSI erase-current-line sequence to PORT to erase the whole line and | |
1252dd32 LC |
182 | move the cursor to the beginning of the line." |
183 | (display "\r\x1b[K" port)) | |
184 | ||
fe65b559 LC |
185 | (define* (display-download-progress file size |
186 | #:key | |
d613c177 | 187 | (tty? #t) |
fe65b559 LC |
188 | start-time (transferred 0) |
189 | (log-port (current-error-port))) | |
190 | "Write the progress report to LOG-PORT. Use START-TIME (a SRFI-19 time | |
191 | object) and TRANSFERRED (a total number of bytes) to determine the | |
d613c177 LC |
192 | throughput. When TTY? is false, assume LOG-PORT is not a tty and do not emit |
193 | ANSI escape codes." | |
fe65b559 LC |
194 | (define elapsed |
195 | (duration->seconds | |
b6f5339d LC |
196 | (time-difference (current-time (time-type start-time)) |
197 | start-time))) | |
198 | ||
d613c177 LC |
199 | (cond ((and (not tty?) |
200 | size (not (zero? size)) | |
201 | transferred) | |
202 | ;; Display a dot for at most every 10%. | |
203 | (when (zero? (modulo (round (* 100. (/ transferred size))) 10)) | |
204 | (display "." log-port) | |
205 | (force-output log-port))) | |
206 | ((and (number? size) (not (zero? size))) | |
207 | (let* ((% (* 100.0 (/ transferred size))) | |
208 | (throughput (/ transferred elapsed)) | |
209 | (left (format #f " ~a ~a" file | |
210 | (byte-count->string size))) | |
211 | (right (format #f "~a/s ~a ~a~6,1f%" | |
212 | (byte-count->string throughput) | |
213 | (seconds->string elapsed) | |
214 | (progress-bar %) %))) | |
215 | (erase-current-line log-port) | |
216 | (display (string-pad-middle left right | |
217 | (current-terminal-columns)) | |
218 | log-port) | |
219 | (force-output log-port))) | |
220 | (else | |
221 | ;; If we don't know the total size, the last transfer will have a 0B | |
222 | ;; size. Don't display it. | |
223 | (unless (zero? transferred) | |
224 | (let* ((throughput (/ transferred elapsed)) | |
225 | (left (format #f " ~a" file)) | |
226 | (right (format #f "~a/s ~a | ~a transferred" | |
227 | (byte-count->string throughput) | |
228 | (seconds->string elapsed) | |
229 | (byte-count->string transferred)))) | |
230 | (erase-current-line log-port) | |
231 | (display (string-pad-middle left right | |
232 | (current-terminal-columns)) | |
233 | log-port) | |
234 | (force-output log-port)))))) | |
fe65b559 | 235 | |
dc0f74e5 LC |
236 | (define %progress-interval |
237 | ;; Default interval between subsequent outputs for rate-limited displays. | |
88bc3c89 | 238 | (make-time time-duration 200000000 0)) |
dc0f74e5 | 239 | |
8c348825 LC |
240 | (define* (progress-reporter/file file size |
241 | #:optional (log-port (current-output-port)) | |
242 | #:key (abbreviation basename)) | |
243 | "Return a <progress-reporter> object to show the progress of FILE's download, | |
244 | which is SIZE bytes long. The progress report is written to LOG-PORT, with | |
245 | ABBREVIATION used to shorten FILE for display." | |
246 | (let ((start-time (current-time time-monotonic)) | |
247 | (transferred 0)) | |
248 | (define (render) | |
fe65b559 LC |
249 | (display-download-progress (abbreviation file) size |
250 | #:start-time start-time | |
251 | #:transferred transferred | |
252 | #:log-port log-port)) | |
8c348825 LC |
253 | |
254 | (progress-reporter | |
255 | (start render) | |
256 | ;; Report the progress every 300ms or longer. | |
257 | (report | |
dc0f74e5 | 258 | (let ((rate-limited-render (rate-limited render %progress-interval))) |
8c348825 LC |
259 | (lambda (value) |
260 | (set! transferred value) | |
261 | (rate-limited-render)))) | |
262 | ;; Don't miss the last report. | |
263 | (stop render)))) | |
264 | ||
4cdb27af LC |
265 | (define* (progress-reporter/bar total |
266 | #:optional | |
267 | (prefix "") | |
268 | (port (current-error-port))) | |
269 | "Return a reporter that shows a progress bar every time one of the TOTAL | |
270 | tasks is performed. Write PREFIX at the beginning of the line." | |
271 | (define done 0) | |
272 | ||
273 | (define (report-progress) | |
274 | (set! done (+ 1 done)) | |
275 | (unless (> done total) | |
276 | (let* ((ratio (* 100. (/ done total)))) | |
3e0a4297 | 277 | (erase-current-line port) |
4cdb27af LC |
278 | (if (string-null? prefix) |
279 | (display (progress-bar ratio (current-terminal-columns)) port) | |
280 | (let ((width (- (current-terminal-columns) | |
281 | (string-length prefix) 3))) | |
282 | (display prefix port) | |
283 | (display " " port) | |
284 | (display (progress-bar ratio width) port))) | |
285 | (force-output port)))) | |
286 | ||
287 | (progress-reporter | |
288 | (start (lambda () | |
289 | (set! done 0))) | |
290 | (report report-progress) | |
291 | (stop (lambda () | |
3e0a4297 | 292 | (erase-current-line port) |
4cdb27af LC |
293 | (unless (string-null? prefix) |
294 | (display prefix port) | |
295 | (newline port)) | |
296 | (force-output port))))) | |
297 | ||
dc0f74e5 LC |
298 | (define* (progress-reporter/trace file url size |
299 | #:optional (log-port (current-output-port))) | |
300 | "Like 'progress-reporter/file', but instead of returning human-readable | |
301 | progress reports, write \"build trace\" lines to be processed elsewhere." | |
42384b51 LC |
302 | (define total 0) ;bytes transferred |
303 | ||
dc0f74e5 LC |
304 | (define (report-progress transferred) |
305 | (define message | |
306 | (format #f "@ download-progress ~a ~a ~a ~a~%" | |
307 | file url (or size "-") transferred)) | |
308 | ||
309 | (display message log-port) ;should be atomic | |
310 | (flush-output-port log-port)) | |
311 | ||
312 | (progress-reporter | |
313 | (start (lambda () | |
42384b51 | 314 | (set! total 0) |
dc0f74e5 LC |
315 | (display (format #f "@ download-started ~a ~a ~a~%" |
316 | file url (or size "-")) | |
317 | log-port))) | |
42384b51 LC |
318 | (report (let ((report (rate-limited report-progress %progress-interval))) |
319 | (lambda (transferred) | |
320 | (set! total transferred) | |
321 | (report transferred)))) | |
dc0f74e5 | 322 | (stop (lambda () |
42384b51 | 323 | (let ((size (or size total))) |
1d0be47a LC |
324 | (report-progress size) |
325 | (display (format #f "@ download-succeeded ~a ~a ~a~%" | |
326 | file url size) | |
327 | log-port)))))) | |
dc0f74e5 | 328 | |
8c348825 LC |
329 | ;; TODO: replace '(@ (guix build utils) dump-port))'. |
330 | (define* (dump-port* in out | |
331 | #:key (buffer-size 16384) | |
332 | (reporter progress-reporter/silent)) | |
333 | "Read as much data as possible from IN and write it to OUT, using chunks of | |
334 | BUFFER-SIZE bytes. After each successful transfer of BUFFER-SIZE bytes or | |
335 | less, report the total number of bytes transferred to the REPORTER, which | |
336 | should be a <progress-reporter> object." | |
337 | (define buffer | |
338 | (make-bytevector buffer-size)) | |
339 | ||
340 | (call-with-progress-reporter reporter | |
341 | (lambda (report) | |
342 | (let loop ((total 0) | |
343 | (bytes (get-bytevector-n! in buffer 0 buffer-size))) | |
344 | (or (eof-object? bytes) | |
345 | (let ((total (+ total bytes))) | |
346 | (put-bytevector out buffer 0 bytes) | |
347 | (report total) | |
348 | (loop total (get-bytevector-n! in buffer 0 buffer-size)))))))) | |
22f06a21 | 349 | |
5ff52145 | 350 | (define* (progress-report-port reporter port #:key (close? #t)) |
22f06a21 | 351 | "Return a port that continuously reports the bytes read from PORT using |
5ff52145 LC |
352 | REPORTER, which should be a <progress-reporter> object. When CLOSE? is true, |
353 | PORT is closed when the returned port is closed." | |
22f06a21 LC |
354 | (match reporter |
355 | (($ <progress-reporter> start report stop) | |
356 | (let* ((total 0) | |
357 | (read! (lambda (bv start count) | |
358 | (let ((n (match (get-bytevector-n! port bv start count) | |
359 | ((? eof-object?) 0) | |
360 | (x x)))) | |
361 | (set! total (+ total n)) | |
362 | (report total) | |
363 | n)))) | |
364 | (start) | |
365 | (make-custom-binary-input-port "progress-port-proc" | |
366 | read! #f #f | |
367 | (lambda () | |
368 | ;; XXX: Kludge! When used through | |
369 | ;; 'decompressed-port', this port ends | |
370 | ;; up being closed twice: once in a | |
371 | ;; child process early on, and at the | |
372 | ;; end in the parent process. Ignore | |
373 | ;; the early close so we don't output | |
374 | ;; a spurious "download-succeeded" | |
375 | ;; trace. | |
376 | (unless (zero? total) | |
377 | (stop)) | |
5ff52145 LC |
378 | (when close? |
379 | (close-port port)))))))) | |
22f06a21 | 380 |