| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2017 Sou Bunnbu <iyzsong@gmail.com> |
| 3 | ;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com> |
| 4 | ;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> |
| 5 | ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> |
| 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 | |
| 35 | start-progress-reporter! |
| 36 | stop-progress-reporter! |
| 37 | progress-reporter-report! |
| 38 | |
| 39 | progress-reporter/silent |
| 40 | progress-reporter/file |
| 41 | progress-reporter/bar |
| 42 | progress-reporter/trace |
| 43 | progress-report-port |
| 44 | |
| 45 | display-download-progress |
| 46 | erase-current-line |
| 47 | progress-bar |
| 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 | |
| 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 | |
| 79 | (define (progress-reporter-report! reporter . args) |
| 80 | "Low-level procedure to lead REPORTER to emit a report." |
| 81 | (match reporter |
| 82 | (($ <progress-reporter> start report stop) |
| 83 | (apply report args)))) |
| 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 | |
| 91 | (define progress-reporter/silent |
| 92 | (make-progress-reporter noop noop noop)) |
| 93 | |
| 94 | \f |
| 95 | ;;; |
| 96 | ;;; File download progress report. |
| 97 | ;;; |
| 98 | |
| 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." |
| 172 | (let* ((bar-width (max 3 (- bar-width 2))) |
| 173 | (fraction (/ % 100)) |
| 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 | |
| 180 | (define (erase-current-line port) |
| 181 | "Write an ANSI erase-current-line sequence to PORT to erase the whole line and |
| 182 | move the cursor to the beginning of the line." |
| 183 | (display "\r\x1b[K" port)) |
| 184 | |
| 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 |
| 194 | (time-difference (current-time (time-type start-time)) |
| 195 | start-time))) |
| 196 | |
| 197 | (if (and (number? size) (not (zero? size))) |
| 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)) |
| 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))))) |
| 225 | |
| 226 | (define %progress-interval |
| 227 | ;; Default interval between subsequent outputs for rate-limited displays. |
| 228 | (make-time time-duration 200000000 0)) |
| 229 | |
| 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) |
| 239 | (display-download-progress (abbreviation file) size |
| 240 | #:start-time start-time |
| 241 | #:transferred transferred |
| 242 | #:log-port log-port)) |
| 243 | |
| 244 | (progress-reporter |
| 245 | (start render) |
| 246 | ;; Report the progress every 300ms or longer. |
| 247 | (report |
| 248 | (let ((rate-limited-render (rate-limited render %progress-interval))) |
| 249 | (lambda (value) |
| 250 | (set! transferred value) |
| 251 | (rate-limited-render)))) |
| 252 | ;; Don't miss the last report. |
| 253 | (stop render)))) |
| 254 | |
| 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)))) |
| 267 | (erase-current-line port) |
| 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 () |
| 282 | (erase-current-line port) |
| 283 | (unless (string-null? prefix) |
| 284 | (display prefix port) |
| 285 | (newline port)) |
| 286 | (force-output port))))) |
| 287 | |
| 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." |
| 292 | (define total 0) ;bytes transferred |
| 293 | |
| 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 () |
| 304 | (set! total 0) |
| 305 | (display (format #f "@ download-started ~a ~a ~a~%" |
| 306 | file url (or size "-")) |
| 307 | log-port))) |
| 308 | (report (let ((report (rate-limited report-progress %progress-interval))) |
| 309 | (lambda (transferred) |
| 310 | (set! total transferred) |
| 311 | (report transferred)))) |
| 312 | (stop (lambda () |
| 313 | (let ((size (or size total))) |
| 314 | (report-progress size) |
| 315 | (display (format #f "@ download-succeeded ~a ~a ~a~%" |
| 316 | file url size) |
| 317 | log-port)))))) |
| 318 | |
| 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)))))))) |
| 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 | |