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 ;;;
   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            (report-progress size)
 308            (display (format #f "@ download-succeeded ~a ~a ~a~%"
 309                             file url
 310                             (or (and=> (stat file #f) stat:size)
 311                                 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))))))))