guix/progress.scm

   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                                     (tty? #t)
 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
 192 throughput.  When TTY? is false, assume LOG-PORT is not a tty and do not emit
 193 ANSI escape codes."
 194   (define elapsed
 195     (duration->seconds
 196      (time-difference (current-time (time-type start-time))
 197                       start-time)))
 198
 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))))))
 235
 236 (define %progress-interval
 237   ;; Default interval between subsequent outputs for rate-limited displays.
 238   (make-time time-duration 200000000 0))
 239
 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)
 249       (display-download-progress (abbreviation file) size
 250                                  #:start-time start-time
 251                                  #:transferred transferred
 252                                  #:log-port log-port))
 253
 254     (progress-reporter
 255      (start render)
 256      ;; Report the progress every 300ms or longer.
 257      (report
 258       (let ((rate-limited-render (rate-limited render %progress-interval)))
 259         (lambda (value)
 260           (set! transferred value)
 261           (rate-limited-render))))
 262      ;; Don't miss the last report.
 263      (stop render))))
 264
 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))))
 277         (erase-current-line port)
 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 ()
 292            (erase-current-line port)
 293            (unless (string-null? prefix)
 294              (display prefix port)
 295              (newline port))
 296            (force-output port)))))
 297
 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."
 302   (define total 0)                                ;bytes transferred
 303
 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 ()
 314             (set! total 0)
 315             (display (format #f "@ download-started ~a ~a ~a~%"
 316                              file url (or size "-"))
 317                      log-port)))
 318    (report (let ((report (rate-limited report-progress %progress-interval)))
 319              (lambda (transferred)
 320                (set! total transferred)
 321                (report transferred))))
 322    (stop (lambda ()
 323            (let ((size (or size total)))
 324              (report-progress size)
 325              (display (format #f "@ download-succeeded ~a ~a ~a~%"
 326                               file url size)
 327                       log-port))))))
 328
 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))))))))
 349
 350 (define* (progress-report-port reporter port #:key (close? #t))
 351   "Return a port that continuously reports the bytes read from PORT using
 352 REPORTER, which should be a <progress-reporter> object.  When CLOSE? is true,
 353 PORT is closed when the returned port is closed."
 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))
 378                                         (when close?
 379                                           (close-port port))))))))
 380