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> | |
88bc3c89 | 4 | ;;; Copyright © 2017, 2018, 2019 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 |
8c348825 | 43 | |
fe65b559 | 44 | display-download-progress |
dc0f74e5 LC |
45 | erase-current-line |
46 | progress-bar | |
8c348825 LC |
47 | byte-count->string |
48 | current-terminal-columns | |
49 | ||
50 | dump-port*)) | |
51 | ||
52 | ;;; Commentary: | |
53 | ;;; | |
54 | ;;; Helper to write progress report code for downloads, etc. | |
55 | ;;; | |
56 | ;;; Code: | |
57 | ||
58 | (define-record-type* <progress-reporter> | |
59 | progress-reporter make-progress-reporter progress-reporter? | |
60 | (start progress-reporter-start) ; thunk | |
61 | (report progress-reporter-report) ; procedure | |
62 | (stop progress-reporter-stop)) ; thunk | |
63 | ||
64 | (define (call-with-progress-reporter reporter proc) | |
65 | "Start REPORTER for progress reporting, and call @code{(@var{proc} report)} | |
66 | with the resulting report procedure. When @var{proc} returns, the REPORTER is | |
67 | stopped." | |
68 | (match reporter | |
69 | (($ <progress-reporter> start report stop) | |
70 | (dynamic-wind start (lambda () (proc report)) stop)))) | |
71 | ||
1fafa2f5 LC |
72 | (define (start-progress-reporter! reporter) |
73 | "Low-level procedure to start REPORTER." | |
74 | (match reporter | |
75 | (($ <progress-reporter> start report stop) | |
76 | (start)))) | |
77 | ||
cfe19684 | 78 | (define (progress-reporter-report! reporter . args) |
1fafa2f5 LC |
79 | "Low-level procedure to lead REPORTER to emit a report." |
80 | (match reporter | |
81 | (($ <progress-reporter> start report stop) | |
cfe19684 | 82 | (apply report args)))) |
1fafa2f5 LC |
83 | |
84 | (define (stop-progress-reporter! reporter) | |
85 | "Low-level procedure to stop REPORTER." | |
86 | (match reporter | |
87 | (($ <progress-reporter> start report stop) | |
88 | (stop)))) | |
89 | ||
8c348825 LC |
90 | (define progress-reporter/silent |
91 | (make-progress-reporter noop noop noop)) | |
92 | ||
93 | \f | |
94 | ;;; | |
95 | ;;; File download progress report. | |
96 | ;;; | |
97 | ||
98 | (cond-expand | |
99 | (guile-2.2 | |
100 | ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and | |
101 | ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it. | |
102 | (define time-monotonic time-tai)) | |
103 | (else #t)) | |
104 | ||
105 | (define (nearest-exact-integer x) | |
106 | "Given a real number X, return the nearest exact integer, with ties going to | |
107 | the nearest exact even integer." | |
108 | (inexact->exact (round x))) | |
109 | ||
110 | (define (duration->seconds duration) | |
111 | "Return the number of seconds represented by DURATION, a 'time-duration' | |
112 | object, as an inexact number." | |
113 | (+ (time-second duration) | |
114 | (/ (time-nanosecond duration) 1e9))) | |
115 | ||
116 | (define (seconds->string duration) | |
117 | "Given DURATION in seconds, return a string representing it in 'mm:ss' or | |
118 | 'hh:mm:ss' format, as needed." | |
119 | (if (not (number? duration)) | |
120 | "00:00" | |
121 | (let* ((total-seconds (nearest-exact-integer duration)) | |
122 | (extra-seconds (modulo total-seconds 3600)) | |
123 | (num-hours (quotient total-seconds 3600)) | |
124 | (hours (and (positive? num-hours) num-hours)) | |
125 | (mins (quotient extra-seconds 60)) | |
126 | (secs (modulo extra-seconds 60))) | |
127 | (format #f "~@[~2,'0d:~]~2,'0d:~2,'0d" hours mins secs)))) | |
128 | ||
129 | (define (byte-count->string size) | |
130 | "Given SIZE in bytes, return a string representing it in a human-readable | |
131 | way." | |
132 | (let ((KiB 1024.) | |
133 | (MiB (expt 1024. 2)) | |
134 | (GiB (expt 1024. 3)) | |
135 | (TiB (expt 1024. 4))) | |
136 | (cond | |
137 | ((< size KiB) (format #f "~dB" (nearest-exact-integer size))) | |
138 | ((< size MiB) (format #f "~dKiB" (nearest-exact-integer (/ size KiB)))) | |
139 | ((< size GiB) (format #f "~,1fMiB" (/ size MiB))) | |
140 | ((< size TiB) (format #f "~,2fGiB" (/ size GiB))) | |
141 | (else (format #f "~,3fTiB" (/ size TiB)))))) | |
142 | ||
143 | (define (string-pad-middle left right len) | |
144 | "Combine LEFT and RIGHT with enough padding in the middle so that the | |
145 | resulting string has length at least LEN (it may overflow). If the string | |
146 | does not overflow, the last char in RIGHT will be flush with the LEN | |
147 | column." | |
148 | (let* ((total-used (+ (string-length left) | |
149 | (string-length right))) | |
150 | (num-spaces (max 1 (- len total-used))) | |
151 | (padding (make-string num-spaces #\space))) | |
152 | (string-append left padding right))) | |
153 | ||
154 | (define (rate-limited proc interval) | |
155 | "Return a procedure that will forward the invocation to PROC when the time | |
156 | elapsed since the previous forwarded invocation is greater or equal to | |
157 | INTERVAL (a time-duration object), otherwise does nothing and returns #f." | |
158 | (let ((previous-at #f)) | |
159 | (lambda args | |
160 | (let* ((now (current-time time-monotonic)) | |
161 | (forward-invocation (lambda () | |
162 | (set! previous-at now) | |
163 | (apply proc args)))) | |
164 | (if previous-at | |
165 | (let ((elapsed (time-difference now previous-at))) | |
166 | (if (time>=? elapsed interval) | |
167 | (forward-invocation) | |
168 | #f)) | |
169 | (forward-invocation)))))) | |
170 | ||
171 | (define current-terminal-columns | |
172 | ;; Number of columns of the terminal. | |
173 | (make-parameter 80)) | |
174 | ||
175 | (define* (progress-bar % #:optional (bar-width 20)) | |
176 | "Return % as a string representing an ASCII-art progress bar. The total | |
177 | width of the bar is BAR-WIDTH." | |
5ed534cc LC |
178 | (let* ((bar-width (max 3 (- bar-width 2))) |
179 | (fraction (/ % 100)) | |
8c348825 LC |
180 | (filled (inexact->exact (floor (* fraction bar-width)))) |
181 | (empty (- bar-width filled))) | |
182 | (format #f "[~a~a]" | |
183 | (make-string filled #\#) | |
184 | (make-string empty #\space)))) | |
185 | ||
3e0a4297 LC |
186 | (define (erase-current-line port) |
187 | "Write an ANSI erase-current-line sequence to PORT to erase the whole line and | |
1252dd32 LC |
188 | move the cursor to the beginning of the line." |
189 | (display "\r\x1b[K" port)) | |
190 | ||
fe65b559 LC |
191 | (define* (display-download-progress file size |
192 | #:key | |
193 | start-time (transferred 0) | |
194 | (log-port (current-error-port))) | |
195 | "Write the progress report to LOG-PORT. Use START-TIME (a SRFI-19 time | |
196 | object) and TRANSFERRED (a total number of bytes) to determine the | |
197 | throughput." | |
198 | (define elapsed | |
199 | (duration->seconds | |
b6f5339d LC |
200 | (time-difference (current-time (time-type start-time)) |
201 | start-time))) | |
202 | ||
0289dc14 | 203 | (if (and (number? size) (not (zero? size))) |
fe65b559 LC |
204 | (let* ((% (* 100.0 (/ transferred size))) |
205 | (throughput (/ transferred elapsed)) | |
206 | (left (format #f " ~a ~a" file | |
207 | (byte-count->string size))) | |
208 | (right (format #f "~a/s ~a ~a~6,1f%" | |
209 | (byte-count->string throughput) | |
210 | (seconds->string elapsed) | |
211 | (progress-bar %) %))) | |
212 | (erase-current-line log-port) | |
213 | (display (string-pad-middle left right | |
214 | (current-terminal-columns)) | |
215 | log-port) | |
216 | (force-output log-port)) | |
d827fd31 CL |
217 | ;; If we don't know the total size, the last transfer will have a 0B |
218 | ;; size. Don't display it. | |
219 | (unless (zero? transferred) | |
220 | (let* ((throughput (/ transferred elapsed)) | |
221 | (left (format #f " ~a" file)) | |
222 | (right (format #f "~a/s ~a | ~a transferred" | |
223 | (byte-count->string throughput) | |
224 | (seconds->string elapsed) | |
225 | (byte-count->string transferred)))) | |
226 | (erase-current-line log-port) | |
227 | (display (string-pad-middle left right | |
228 | (current-terminal-columns)) | |
229 | log-port) | |
230 | (force-output log-port))))) | |
fe65b559 | 231 | |
dc0f74e5 LC |
232 | (define %progress-interval |
233 | ;; Default interval between subsequent outputs for rate-limited displays. | |
88bc3c89 | 234 | (make-time time-duration 200000000 0)) |
dc0f74e5 | 235 | |
8c348825 LC |
236 | (define* (progress-reporter/file file size |
237 | #:optional (log-port (current-output-port)) | |
238 | #:key (abbreviation basename)) | |
239 | "Return a <progress-reporter> object to show the progress of FILE's download, | |
240 | which is SIZE bytes long. The progress report is written to LOG-PORT, with | |
241 | ABBREVIATION used to shorten FILE for display." | |
242 | (let ((start-time (current-time time-monotonic)) | |
243 | (transferred 0)) | |
244 | (define (render) | |
fe65b559 LC |
245 | (display-download-progress (abbreviation file) size |
246 | #:start-time start-time | |
247 | #:transferred transferred | |
248 | #:log-port log-port)) | |
8c348825 LC |
249 | |
250 | (progress-reporter | |
251 | (start render) | |
252 | ;; Report the progress every 300ms or longer. | |
253 | (report | |
dc0f74e5 | 254 | (let ((rate-limited-render (rate-limited render %progress-interval))) |
8c348825 LC |
255 | (lambda (value) |
256 | (set! transferred value) | |
257 | (rate-limited-render)))) | |
258 | ;; Don't miss the last report. | |
259 | (stop render)))) | |
260 | ||
4cdb27af LC |
261 | (define* (progress-reporter/bar total |
262 | #:optional | |
263 | (prefix "") | |
264 | (port (current-error-port))) | |
265 | "Return a reporter that shows a progress bar every time one of the TOTAL | |
266 | tasks is performed. Write PREFIX at the beginning of the line." | |
267 | (define done 0) | |
268 | ||
269 | (define (report-progress) | |
270 | (set! done (+ 1 done)) | |
271 | (unless (> done total) | |
272 | (let* ((ratio (* 100. (/ done total)))) | |
3e0a4297 | 273 | (erase-current-line port) |
4cdb27af LC |
274 | (if (string-null? prefix) |
275 | (display (progress-bar ratio (current-terminal-columns)) port) | |
276 | (let ((width (- (current-terminal-columns) | |
277 | (string-length prefix) 3))) | |
278 | (display prefix port) | |
279 | (display " " port) | |
280 | (display (progress-bar ratio width) port))) | |
281 | (force-output port)))) | |
282 | ||
283 | (progress-reporter | |
284 | (start (lambda () | |
285 | (set! done 0))) | |
286 | (report report-progress) | |
287 | (stop (lambda () | |
3e0a4297 | 288 | (erase-current-line port) |
4cdb27af LC |
289 | (unless (string-null? prefix) |
290 | (display prefix port) | |
291 | (newline port)) | |
292 | (force-output port))))) | |
293 | ||
dc0f74e5 LC |
294 | (define* (progress-reporter/trace file url size |
295 | #:optional (log-port (current-output-port))) | |
296 | "Like 'progress-reporter/file', but instead of returning human-readable | |
297 | progress reports, write \"build trace\" lines to be processed elsewhere." | |
42384b51 LC |
298 | (define total 0) ;bytes transferred |
299 | ||
dc0f74e5 LC |
300 | (define (report-progress transferred) |
301 | (define message | |
302 | (format #f "@ download-progress ~a ~a ~a ~a~%" | |
303 | file url (or size "-") transferred)) | |
304 | ||
305 | (display message log-port) ;should be atomic | |
306 | (flush-output-port log-port)) | |
307 | ||
308 | (progress-reporter | |
309 | (start (lambda () | |
42384b51 | 310 | (set! total 0) |
dc0f74e5 LC |
311 | (display (format #f "@ download-started ~a ~a ~a~%" |
312 | file url (or size "-")) | |
313 | log-port))) | |
42384b51 LC |
314 | (report (let ((report (rate-limited report-progress %progress-interval))) |
315 | (lambda (transferred) | |
316 | (set! total transferred) | |
317 | (report transferred)))) | |
dc0f74e5 | 318 | (stop (lambda () |
42384b51 | 319 | (let ((size (or size total))) |
1d0be47a LC |
320 | (report-progress size) |
321 | (display (format #f "@ download-succeeded ~a ~a ~a~%" | |
322 | file url size) | |
323 | log-port)))))) | |
dc0f74e5 | 324 | |
8c348825 LC |
325 | ;; TODO: replace '(@ (guix build utils) dump-port))'. |
326 | (define* (dump-port* in out | |
327 | #:key (buffer-size 16384) | |
328 | (reporter progress-reporter/silent)) | |
329 | "Read as much data as possible from IN and write it to OUT, using chunks of | |
330 | BUFFER-SIZE bytes. After each successful transfer of BUFFER-SIZE bytes or | |
331 | less, report the total number of bytes transferred to the REPORTER, which | |
332 | should be a <progress-reporter> object." | |
333 | (define buffer | |
334 | (make-bytevector buffer-size)) | |
335 | ||
336 | (call-with-progress-reporter reporter | |
337 | (lambda (report) | |
338 | (let loop ((total 0) | |
339 | (bytes (get-bytevector-n! in buffer 0 buffer-size))) | |
340 | (or (eof-object? bytes) | |
341 | (let ((total (+ total bytes))) | |
342 | (put-bytevector out buffer 0 bytes) | |
343 | (report total) | |
344 | (loop total (get-bytevector-n! in buffer 0 buffer-size)))))))) |