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 | |
187 | start-time (transferred 0) | |
188 | (log-port (current-error-port))) | |
189 | "Write the progress report to LOG-PORT. Use START-TIME (a SRFI-19 time | |
190 | object) and TRANSFERRED (a total number of bytes) to determine the | |
191 | throughput." | |
192 | (define elapsed | |
193 | (duration->seconds | |
b6f5339d LC |
194 | (time-difference (current-time (time-type start-time)) |
195 | start-time))) | |
196 | ||
0289dc14 | 197 | (if (and (number? size) (not (zero? size))) |
fe65b559 LC |
198 | (let* ((% (* 100.0 (/ transferred size))) |
199 | (throughput (/ transferred elapsed)) | |
200 | (left (format #f " ~a ~a" file | |
201 | (byte-count->string size))) | |
202 | (right (format #f "~a/s ~a ~a~6,1f%" | |
203 | (byte-count->string throughput) | |
204 | (seconds->string elapsed) | |
205 | (progress-bar %) %))) | |
206 | (erase-current-line log-port) | |
207 | (display (string-pad-middle left right | |
208 | (current-terminal-columns)) | |
209 | log-port) | |
210 | (force-output log-port)) | |
d827fd31 CL |
211 | ;; If we don't know the total size, the last transfer will have a 0B |
212 | ;; size. Don't display it. | |
213 | (unless (zero? transferred) | |
214 | (let* ((throughput (/ transferred elapsed)) | |
215 | (left (format #f " ~a" file)) | |
216 | (right (format #f "~a/s ~a | ~a transferred" | |
217 | (byte-count->string throughput) | |
218 | (seconds->string elapsed) | |
219 | (byte-count->string transferred)))) | |
220 | (erase-current-line log-port) | |
221 | (display (string-pad-middle left right | |
222 | (current-terminal-columns)) | |
223 | log-port) | |
224 | (force-output log-port))))) | |
fe65b559 | 225 | |
dc0f74e5 LC |
226 | (define %progress-interval |
227 | ;; Default interval between subsequent outputs for rate-limited displays. | |
88bc3c89 | 228 | (make-time time-duration 200000000 0)) |
dc0f74e5 | 229 | |
8c348825 LC |
230 | (define* (progress-reporter/file file size |
231 | #:optional (log-port (current-output-port)) | |
232 | #:key (abbreviation basename)) | |
233 | "Return a <progress-reporter> object to show the progress of FILE's download, | |
234 | which is SIZE bytes long. The progress report is written to LOG-PORT, with | |
235 | ABBREVIATION used to shorten FILE for display." | |
236 | (let ((start-time (current-time time-monotonic)) | |
237 | (transferred 0)) | |
238 | (define (render) | |
fe65b559 LC |
239 | (display-download-progress (abbreviation file) size |
240 | #:start-time start-time | |
241 | #:transferred transferred | |
242 | #:log-port log-port)) | |
8c348825 LC |
243 | |
244 | (progress-reporter | |
245 | (start render) | |
246 | ;; Report the progress every 300ms or longer. | |
247 | (report | |
dc0f74e5 | 248 | (let ((rate-limited-render (rate-limited render %progress-interval))) |
8c348825 LC |
249 | (lambda (value) |
250 | (set! transferred value) | |
251 | (rate-limited-render)))) | |
252 | ;; Don't miss the last report. | |
253 | (stop render)))) | |
254 | ||
4cdb27af LC |
255 | (define* (progress-reporter/bar total |
256 | #:optional | |
257 | (prefix "") | |
258 | (port (current-error-port))) | |
259 | "Return a reporter that shows a progress bar every time one of the TOTAL | |
260 | tasks is performed. Write PREFIX at the beginning of the line." | |
261 | (define done 0) | |
262 | ||
263 | (define (report-progress) | |
264 | (set! done (+ 1 done)) | |
265 | (unless (> done total) | |
266 | (let* ((ratio (* 100. (/ done total)))) | |
3e0a4297 | 267 | (erase-current-line port) |
4cdb27af LC |
268 | (if (string-null? prefix) |
269 | (display (progress-bar ratio (current-terminal-columns)) port) | |
270 | (let ((width (- (current-terminal-columns) | |
271 | (string-length prefix) 3))) | |
272 | (display prefix port) | |
273 | (display " " port) | |
274 | (display (progress-bar ratio width) port))) | |
275 | (force-output port)))) | |
276 | ||
277 | (progress-reporter | |
278 | (start (lambda () | |
279 | (set! done 0))) | |
280 | (report report-progress) | |
281 | (stop (lambda () | |
3e0a4297 | 282 | (erase-current-line port) |
4cdb27af LC |
283 | (unless (string-null? prefix) |
284 | (display prefix port) | |
285 | (newline port)) | |
286 | (force-output port))))) | |
287 | ||
dc0f74e5 LC |
288 | (define* (progress-reporter/trace file url size |
289 | #:optional (log-port (current-output-port))) | |
290 | "Like 'progress-reporter/file', but instead of returning human-readable | |
291 | progress reports, write \"build trace\" lines to be processed elsewhere." | |
42384b51 LC |
292 | (define total 0) ;bytes transferred |
293 | ||
dc0f74e5 LC |
294 | (define (report-progress transferred) |
295 | (define message | |
296 | (format #f "@ download-progress ~a ~a ~a ~a~%" | |
297 | file url (or size "-") transferred)) | |
298 | ||
299 | (display message log-port) ;should be atomic | |
300 | (flush-output-port log-port)) | |
301 | ||
302 | (progress-reporter | |
303 | (start (lambda () | |
42384b51 | 304 | (set! total 0) |
dc0f74e5 LC |
305 | (display (format #f "@ download-started ~a ~a ~a~%" |
306 | file url (or size "-")) | |
307 | log-port))) | |
42384b51 LC |
308 | (report (let ((report (rate-limited report-progress %progress-interval))) |
309 | (lambda (transferred) | |
310 | (set! total transferred) | |
311 | (report transferred)))) | |
dc0f74e5 | 312 | (stop (lambda () |
42384b51 | 313 | (let ((size (or size total))) |
1d0be47a LC |
314 | (report-progress size) |
315 | (display (format #f "@ download-succeeded ~a ~a ~a~%" | |
316 | file url size) | |
317 | log-port)))))) | |
dc0f74e5 | 318 | |
8c348825 LC |
319 | ;; TODO: replace '(@ (guix build utils) dump-port))'. |
320 | (define* (dump-port* in out | |
321 | #:key (buffer-size 16384) | |
322 | (reporter progress-reporter/silent)) | |
323 | "Read as much data as possible from IN and write it to OUT, using chunks of | |
324 | BUFFER-SIZE bytes. After each successful transfer of BUFFER-SIZE bytes or | |
325 | less, report the total number of bytes transferred to the REPORTER, which | |
326 | should be a <progress-reporter> object." | |
327 | (define buffer | |
328 | (make-bytevector buffer-size)) | |
329 | ||
330 | (call-with-progress-reporter reporter | |
331 | (lambda (report) | |
332 | (let loop ((total 0) | |
333 | (bytes (get-bytevector-n! in buffer 0 buffer-size))) | |
334 | (or (eof-object? bytes) | |
335 | (let ((total (+ total bytes))) | |
336 | (put-bytevector out buffer 0 bytes) | |
337 | (report total) | |
338 | (loop total (get-bytevector-n! in buffer 0 buffer-size)))))))) | |
22f06a21 LC |
339 | |
340 | (define (progress-report-port reporter port) | |
341 | "Return a port that continuously reports the bytes read from PORT using | |
342 | REPORTER, which should be a <progress-reporter> object." | |
343 | (match reporter | |
344 | (($ <progress-reporter> start report stop) | |
345 | (let* ((total 0) | |
346 | (read! (lambda (bv start count) | |
347 | (let ((n (match (get-bytevector-n! port bv start count) | |
348 | ((? eof-object?) 0) | |
349 | (x x)))) | |
350 | (set! total (+ total n)) | |
351 | (report total) | |
352 | n)))) | |
353 | (start) | |
354 | (make-custom-binary-input-port "progress-port-proc" | |
355 | read! #f #f | |
356 | (lambda () | |
357 | ;; XXX: Kludge! When used through | |
358 | ;; 'decompressed-port', this port ends | |
359 | ;; up being closed twice: once in a | |
360 | ;; child process early on, and at the | |
361 | ;; end in the parent process. Ignore | |
362 | ;; the early close so we don't output | |
363 | ;; a spurious "download-succeeded" | |
364 | ;; trace. | |
365 | (unless (zero? total) | |
366 | (stop)) | |
367 | (close-port port))))))) | |
368 |