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 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
  44             display-download-progress
  45             erase-current-line
  46             progress-bar
  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
  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
  78 (define (progress-reporter-report! reporter . args)
  79   "Low-level procedure to lead REPORTER to emit a report."
  80   (match reporter
  81     (($ <progress-reporter> start report stop)
  82      (apply report args))))
  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
  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."
 178   (let* ((bar-width (max 3 (- bar-width 2)))
 179          (fraction (/ % 100))
 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
 186 (define (erase-current-line port)
 187   "Write an ANSI erase-current-line sequence to PORT to erase the whole line and
 188 move the cursor to the beginning of the line."
 189   (display "\r\x1b[K" port))
 190
 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
 200      (time-difference (current-time (time-type start-time))
 201                       start-time)))
 202
 203   (if (and (number? size) (not (zero? size)))
 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))
 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)))))
 231
 232 (define %progress-interval
 233   ;; Default interval between subsequent outputs for rate-limited displays.
 234   (make-time time-duration 200000000 0))
 235
 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)
 245       (display-download-progress (abbreviation file) size
 246                                  #:start-time start-time
 247                                  #:transferred transferred
 248                                  #:log-port log-port))
 249
 250     (progress-reporter
 251      (start render)
 252      ;; Report the progress every 300ms or longer.
 253      (report
 254       (let ((rate-limited-render (rate-limited render %progress-interval)))
 255         (lambda (value)
 256           (set! transferred value)
 257           (rate-limited-render))))
 258      ;; Don't miss the last report.
 259      (stop render))))
 260
 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))))
 273         (erase-current-line port)
 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 ()
 288            (erase-current-line port)
 289            (unless (string-null? prefix)
 290              (display prefix port)
 291              (newline port))
 292            (force-output port)))))
 293
 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."
 298   (define total 0)                                ;bytes transferred
 299
 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 ()
 310             (set! total 0)
 311             (display (format #f "@ download-started ~a ~a ~a~%"
 312                              file url (or size "-"))
 313                      log-port)))
 314    (report (let ((report (rate-limited report-progress %progress-interval)))
 315              (lambda (transferred)
 316                (set! total transferred)
 317                (report transferred))))
 318    (stop (lambda ()
 319            (let ((size (or size total)))
 320              (report-progress size)
 321              (display (format #f "@ download-succeeded ~a ~a ~a~%"
 322                               file url size)
 323                       log-port))))))
 324
 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))))))))