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 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-monotonic) start-time)))
 201   (if (and (number? size) (not (zero? size)))
 202       (let* ((%  (* 100.0 (/ transferred size)))
 203              (throughput (/ transferred elapsed))
 204              (left       (format #f " ~a  ~a" file
 205                                  (byte-count->string size)))
 206              (right      (format #f "~a/s ~a ~a~6,1f%"
 207                                  (byte-count->string throughput)
 208                                  (seconds->string elapsed)
 209                                  (progress-bar %) %)))
 210         (erase-current-line log-port)
 211         (display (string-pad-middle left right
 212                                     (current-terminal-columns))
 213                  log-port)
 214         (force-output log-port))
 215       ;; If we don't know the total size, the last transfer will have a 0B
 216       ;; size.  Don't display it.
 217       (unless (zero? transferred)
 218         (let* ((throughput (/ transferred elapsed))
 219                (left       (format #f " ~a" file))
 220                (right      (format #f "~a/s ~a | ~a transferred"
 221                                    (byte-count->string throughput)
 222                                    (seconds->string elapsed)
 223                                    (byte-count->string transferred))))
 224           (erase-current-line log-port)
 225           (display (string-pad-middle left right
 226                                       (current-terminal-columns))
 227                    log-port)
 228           (force-output log-port)))))
 229
 230 (define %progress-interval
 231   ;; Default interval between subsequent outputs for rate-limited displays.
 232   (make-time time-monotonic 200000000 0))
 233
 234 (define* (progress-reporter/file file size
 235                                  #:optional (log-port (current-output-port))
 236                                  #:key (abbreviation basename))
 237   "Return a <progress-reporter> object to show the progress of FILE's download,
 238 which is SIZE bytes long.  The progress report is written to LOG-PORT, with
 239 ABBREVIATION used to shorten FILE for display."
 240   (let ((start-time (current-time time-monotonic))
 241         (transferred 0))
 242     (define (render)
 243       (display-download-progress (abbreviation file) size
 244                                  #:start-time start-time
 245                                  #:transferred transferred
 246                                  #:log-port log-port))
 247
 248     (progress-reporter
 249      (start render)
 250      ;; Report the progress every 300ms or longer.
 251      (report
 252       (let ((rate-limited-render (rate-limited render %progress-interval)))
 253         (lambda (value)
 254           (set! transferred value)
 255           (rate-limited-render))))
 256      ;; Don't miss the last report.
 257      (stop render))))
 258
 259 (define* (progress-reporter/bar total
 260                                 #:optional
 261                                 (prefix "")
 262                                 (port (current-error-port)))
 263   "Return a reporter that shows a progress bar every time one of the TOTAL
 264 tasks is performed.  Write PREFIX at the beginning of the line."
 265   (define done 0)
 266
 267   (define (report-progress)
 268     (set! done (+ 1 done))
 269     (unless (> done total)
 270       (let* ((ratio (* 100. (/ done total))))
 271         (erase-current-line port)
 272         (if (string-null? prefix)
 273             (display (progress-bar ratio (current-terminal-columns)) port)
 274             (let ((width (- (current-terminal-columns)
 275                             (string-length prefix) 3)))
 276               (display prefix port)
 277               (display "  " port)
 278               (display (progress-bar ratio width) port)))
 279         (force-output port))))
 280
 281   (progress-reporter
 282    (start (lambda ()
 283             (set! done 0)))
 284    (report report-progress)
 285    (stop (lambda ()
 286            (erase-current-line port)
 287            (unless (string-null? prefix)
 288              (display prefix port)
 289              (newline port))
 290            (force-output port)))))
 291
 292 (define* (progress-reporter/trace file url size
 293                                   #:optional (log-port (current-output-port)))
 294   "Like 'progress-reporter/file', but instead of returning human-readable
 295 progress reports, write \"build trace\" lines to be processed elsewhere."
 296   (define total 0)                                ;bytes transferred
 297
 298   (define (report-progress transferred)
 299     (define message
 300       (format #f "@ download-progress ~a ~a ~a ~a~%"
 301               file url (or size "-") transferred))
 302
 303     (display message log-port)                    ;should be atomic
 304     (flush-output-port log-port))
 305
 306   (progress-reporter
 307    (start (lambda ()
 308             (set! total 0)
 309             (display (format #f "@ download-started ~a ~a ~a~%"
 310                              file url (or size "-"))
 311                      log-port)))
 312    (report (let ((report (rate-limited report-progress %progress-interval)))
 313              (lambda (transferred)
 314                (set! total transferred)
 315                (report transferred))))
 316    (stop (lambda ()
 317            (let ((size (or size total)))
 318              (report-progress size)
 319              (display (format #f "@ download-succeeded ~a ~a ~a~%"
 320                               file url size)
 321                       log-port))))))
 322
 323 ;; TODO: replace '(@ (guix build utils) dump-port))'.
 324 (define* (dump-port* in out
 325                      #:key (buffer-size 16384)
 326                      (reporter progress-reporter/silent))
 327   "Read as much data as possible from IN and write it to OUT, using chunks of
 328 BUFFER-SIZE bytes.  After each successful transfer of BUFFER-SIZE bytes or
 329 less, report the total number of bytes transferred to the REPORTER, which
 330 should be a <progress-reporter> object."
 331   (define buffer
 332     (make-bytevector buffer-size))
 333
 334   (call-with-progress-reporter reporter
 335     (lambda (report)
 336       (let loop ((total 0)
 337                  (bytes (get-bytevector-n! in buffer 0 buffer-size)))
 338         (or (eof-object? bytes)
 339             (let ((total (+ total bytes)))
 340               (put-bytevector out buffer 0 bytes)
 341               (report total)
 342               (loop total (get-bytevector-n! in buffer 0 buffer-size))))))))