| 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 Ludovic Courtès <ludo@gnu.org> |
| 5 | ;;; |
| 6 | ;;; This file is part of GNU Guix. |
| 7 | ;;; |
| 8 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
| 9 | ;;; under the terms of the GNU General Public License as published by |
| 10 | ;;; the Free Software Foundation; either version 3 of the License, or (at |
| 11 | ;;; your option) any later version. |
| 12 | ;;; |
| 13 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
| 14 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
| 15 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 16 | ;;; GNU General Public License for more details. |
| 17 | ;;; |
| 18 | ;;; You should have received a copy of the GNU General Public License |
| 19 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
| 20 | |
| 21 | (define-module (guix progress) |
| 22 | #:use-module (guix records) |
| 23 | #:use-module (srfi srfi-19) |
| 24 | #:use-module (rnrs io ports) |
| 25 | #:use-module (rnrs bytevectors) |
| 26 | #:use-module (ice-9 format) |
| 27 | #:use-module (ice-9 match) |
| 28 | #:export (<progress-reporter> |
| 29 | progress-reporter |
| 30 | make-progress-reporter |
| 31 | progress-reporter? |
| 32 | call-with-progress-reporter |
| 33 | |
| 34 | start-progress-reporter! |
| 35 | stop-progress-reporter! |
| 36 | progress-reporter-report! |
| 37 | |
| 38 | progress-reporter/silent |
| 39 | progress-reporter/file |
| 40 | progress-reporter/bar |
| 41 | progress-reporter/trace |
| 42 | |
| 43 | display-download-progress |
| 44 | erase-current-line |
| 45 | progress-bar |
| 46 | byte-count->string |
| 47 | current-terminal-columns |
| 48 | |
| 49 | dump-port*)) |
| 50 | |
| 51 | ;;; Commentary: |
| 52 | ;;; |
| 53 | ;;; Helper to write progress report code for downloads, etc. |
| 54 | ;;; |
| 55 | ;;; Code: |
| 56 | |
| 57 | (define-record-type* <progress-reporter> |
| 58 | progress-reporter make-progress-reporter progress-reporter? |
| 59 | (start progress-reporter-start) ; thunk |
| 60 | (report progress-reporter-report) ; procedure |
| 61 | (stop progress-reporter-stop)) ; thunk |
| 62 | |
| 63 | (define (call-with-progress-reporter reporter proc) |
| 64 | "Start REPORTER for progress reporting, and call @code{(@var{proc} report)} |
| 65 | with the resulting report procedure. When @var{proc} returns, the REPORTER is |
| 66 | stopped." |
| 67 | (match reporter |
| 68 | (($ <progress-reporter> start report stop) |
| 69 | (dynamic-wind start (lambda () (proc report)) stop)))) |
| 70 | |
| 71 | (define (start-progress-reporter! reporter) |
| 72 | "Low-level procedure to start REPORTER." |
| 73 | (match reporter |
| 74 | (($ <progress-reporter> start report stop) |
| 75 | (start)))) |
| 76 | |
| 77 | (define (progress-reporter-report! reporter . args) |
| 78 | "Low-level procedure to lead REPORTER to emit a report." |
| 79 | (match reporter |
| 80 | (($ <progress-reporter> start report stop) |
| 81 | (apply report args)))) |
| 82 | |
| 83 | (define (stop-progress-reporter! reporter) |
| 84 | "Low-level procedure to stop REPORTER." |
| 85 | (match reporter |
| 86 | (($ <progress-reporter> start report stop) |
| 87 | (stop)))) |
| 88 | |
| 89 | (define progress-reporter/silent |
| 90 | (make-progress-reporter noop noop noop)) |
| 91 | |
| 92 | \f |
| 93 | ;;; |
| 94 | ;;; File download progress report. |
| 95 | ;;; |
| 96 | |
| 97 | (cond-expand |
| 98 | (guile-2.2 |
| 99 | ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and |
| 100 | ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it. |
| 101 | (define time-monotonic time-tai)) |
| 102 | (else #t)) |
| 103 | |
| 104 | (define (nearest-exact-integer x) |
| 105 | "Given a real number X, return the nearest exact integer, with ties going to |
| 106 | the nearest exact even integer." |
| 107 | (inexact->exact (round x))) |
| 108 | |
| 109 | (define (duration->seconds duration) |
| 110 | "Return the number of seconds represented by DURATION, a 'time-duration' |
| 111 | object, as an inexact number." |
| 112 | (+ (time-second duration) |
| 113 | (/ (time-nanosecond duration) 1e9))) |
| 114 | |
| 115 | (define (seconds->string duration) |
| 116 | "Given DURATION in seconds, return a string representing it in 'mm:ss' or |
| 117 | 'hh:mm:ss' format, as needed." |
| 118 | (if (not (number? duration)) |
| 119 | "00:00" |
| 120 | (let* ((total-seconds (nearest-exact-integer duration)) |
| 121 | (extra-seconds (modulo total-seconds 3600)) |
| 122 | (num-hours (quotient total-seconds 3600)) |
| 123 | (hours (and (positive? num-hours) num-hours)) |
| 124 | (mins (quotient extra-seconds 60)) |
| 125 | (secs (modulo extra-seconds 60))) |
| 126 | (format #f "~@[~2,'0d:~]~2,'0d:~2,'0d" hours mins secs)))) |
| 127 | |
| 128 | (define (byte-count->string size) |
| 129 | "Given SIZE in bytes, return a string representing it in a human-readable |
| 130 | way." |
| 131 | (let ((KiB 1024.) |
| 132 | (MiB (expt 1024. 2)) |
| 133 | (GiB (expt 1024. 3)) |
| 134 | (TiB (expt 1024. 4))) |
| 135 | (cond |
| 136 | ((< size KiB) (format #f "~dB" (nearest-exact-integer size))) |
| 137 | ((< size MiB) (format #f "~dKiB" (nearest-exact-integer (/ size KiB)))) |
| 138 | ((< size GiB) (format #f "~,1fMiB" (/ size MiB))) |
| 139 | ((< size TiB) (format #f "~,2fGiB" (/ size GiB))) |
| 140 | (else (format #f "~,3fTiB" (/ size TiB)))))) |
| 141 | |
| 142 | (define (string-pad-middle left right len) |
| 143 | "Combine LEFT and RIGHT with enough padding in the middle so that the |
| 144 | resulting string has length at least LEN (it may overflow). If the string |
| 145 | does not overflow, the last char in RIGHT will be flush with the LEN |
| 146 | column." |
| 147 | (let* ((total-used (+ (string-length left) |
| 148 | (string-length right))) |
| 149 | (num-spaces (max 1 (- len total-used))) |
| 150 | (padding (make-string num-spaces #\space))) |
| 151 | (string-append left padding right))) |
| 152 | |
| 153 | (define (rate-limited proc interval) |
| 154 | "Return a procedure that will forward the invocation to PROC when the time |
| 155 | elapsed since the previous forwarded invocation is greater or equal to |
| 156 | INTERVAL (a time-duration object), otherwise does nothing and returns #f." |
| 157 | (let ((previous-at #f)) |
| 158 | (lambda args |
| 159 | (let* ((now (current-time time-monotonic)) |
| 160 | (forward-invocation (lambda () |
| 161 | (set! previous-at now) |
| 162 | (apply proc args)))) |
| 163 | (if previous-at |
| 164 | (let ((elapsed (time-difference now previous-at))) |
| 165 | (if (time>=? elapsed interval) |
| 166 | (forward-invocation) |
| 167 | #f)) |
| 168 | (forward-invocation)))))) |
| 169 | |
| 170 | (define current-terminal-columns |
| 171 | ;; Number of columns of the terminal. |
| 172 | (make-parameter 80)) |
| 173 | |
| 174 | (define* (progress-bar % #:optional (bar-width 20)) |
| 175 | "Return % as a string representing an ASCII-art progress bar. The total |
| 176 | width of the bar is BAR-WIDTH." |
| 177 | (let* ((bar-width (max 3 (- bar-width 2))) |
| 178 | (fraction (/ % 100)) |
| 179 | (filled (inexact->exact (floor (* fraction bar-width)))) |
| 180 | (empty (- bar-width filled))) |
| 181 | (format #f "[~a~a]" |
| 182 | (make-string filled #\#) |
| 183 | (make-string empty #\space)))) |
| 184 | |
| 185 | (define (erase-current-line port) |
| 186 | "Write an ANSI erase-current-line sequence to PORT to erase the whole line and |
| 187 | move the cursor to the beginning of the line." |
| 188 | (display "\r\x1b[K" port)) |
| 189 | |
| 190 | (define* (display-download-progress file size |
| 191 | #:key |
| 192 | start-time (transferred 0) |
| 193 | (log-port (current-error-port))) |
| 194 | "Write the progress report to LOG-PORT. Use START-TIME (a SRFI-19 time |
| 195 | object) and TRANSFERRED (a total number of bytes) to determine the |
| 196 | throughput." |
| 197 | (define elapsed |
| 198 | (duration->seconds |
| 199 | (time-difference (current-time time-monotonic) start-time))) |
| 200 | (if (number? size) |
| 201 | (let* ((% (* 100.0 (/ transferred size))) |
| 202 | (throughput (/ transferred elapsed)) |
| 203 | (left (format #f " ~a ~a" file |
| 204 | (byte-count->string size))) |
| 205 | (right (format #f "~a/s ~a ~a~6,1f%" |
| 206 | (byte-count->string throughput) |
| 207 | (seconds->string elapsed) |
| 208 | (progress-bar %) %))) |
| 209 | (erase-current-line log-port) |
| 210 | (display (string-pad-middle left right |
| 211 | (current-terminal-columns)) |
| 212 | log-port) |
| 213 | (force-output log-port)) |
| 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-monotonic 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 (report-progress transferred) |
| 293 | (define message |
| 294 | (format #f "@ download-progress ~a ~a ~a ~a~%" |
| 295 | file url (or size "-") transferred)) |
| 296 | |
| 297 | (display message log-port) ;should be atomic |
| 298 | (flush-output-port log-port)) |
| 299 | |
| 300 | (progress-reporter |
| 301 | (start (lambda () |
| 302 | (display (format #f "@ download-started ~a ~a ~a~%" |
| 303 | file url (or size "-")) |
| 304 | log-port))) |
| 305 | (report (rate-limited report-progress %progress-interval)) |
| 306 | (stop (lambda () |
| 307 | (let ((size (or (and=> (stat file #f) stat:size) |
| 308 | size))) |
| 309 | (report-progress size) |
| 310 | (display (format #f "@ download-succeeded ~a ~a ~a~%" |
| 311 | file url size) |
| 312 | log-port)))))) |
| 313 | |
| 314 | ;; TODO: replace '(@ (guix build utils) dump-port))'. |
| 315 | (define* (dump-port* in out |
| 316 | #:key (buffer-size 16384) |
| 317 | (reporter progress-reporter/silent)) |
| 318 | "Read as much data as possible from IN and write it to OUT, using chunks of |
| 319 | BUFFER-SIZE bytes. After each successful transfer of BUFFER-SIZE bytes or |
| 320 | less, report the total number of bytes transferred to the REPORTER, which |
| 321 | should be a <progress-reporter> object." |
| 322 | (define buffer |
| 323 | (make-bytevector buffer-size)) |
| 324 | |
| 325 | (call-with-progress-reporter reporter |
| 326 | (lambda (report) |
| 327 | (let loop ((total 0) |
| 328 | (bytes (get-bytevector-n! in buffer 0 buffer-size))) |
| 329 | (or (eof-object? bytes) |
| 330 | (let ((total (+ total bytes))) |
| 331 | (put-bytevector out buffer 0 bytes) |
| 332 | (report total) |
| 333 | (loop total (get-bytevector-n! in buffer 0 buffer-size)))))))) |