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 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
  42             byte-count->string
  43             current-terminal-columns
  44
  45             dump-port*))
  46
  47 ;;; Commentary:
  48 ;;;
  49 ;;; Helper to write progress report code for downloads, etc.
  50 ;;;
  51 ;;; Code:
  52
  53 (define-record-type* <progress-reporter>
  54   progress-reporter make-progress-reporter progress-reporter?
  55   (start   progress-reporter-start)     ; thunk
  56   (report  progress-reporter-report)    ; procedure
  57   (stop    progress-reporter-stop))     ; thunk
  58
  59 (define (call-with-progress-reporter reporter proc)
  60   "Start REPORTER for progress reporting, and call @code{(@var{proc} report)}
  61 with the resulting report procedure.  When @var{proc} returns, the REPORTER is
  62 stopped."
  63   (match reporter
  64     (($ <progress-reporter> start report stop)
  65      (dynamic-wind start (lambda () (proc report)) stop))))
  66
  67 (define (start-progress-reporter! reporter)
  68   "Low-level procedure to start REPORTER."
  69   (match reporter
  70     (($ <progress-reporter> start report stop)
  71      (start))))
  72
  73 (define (progress-reporter-report! reporter)
  74   "Low-level procedure to lead REPORTER to emit a report."
  75   (match reporter
  76     (($ <progress-reporter> start report stop)
  77      (report))))
  78
  79 (define (stop-progress-reporter! reporter)
  80   "Low-level procedure to stop REPORTER."
  81   (match reporter
  82     (($ <progress-reporter> start report stop)
  83      (stop))))
  84
  85 (define progress-reporter/silent
  86   (make-progress-reporter noop noop noop))
  87
  88 \f
  89 ;;;
  90 ;;; File download progress report.
  91 ;;;
  92
  93 (cond-expand
  94   (guile-2.2
  95    ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
  96    ;; nanoseconds swapped (fixed in Guile commit 886ac3e).  Work around it.
  97    (define time-monotonic time-tai))
  98   (else #t))
  99
 100 (define (nearest-exact-integer x)
 101   "Given a real number X, return the nearest exact integer, with ties going to
 102 the nearest exact even integer."
 103   (inexact->exact (round x)))
 104
 105 (define (duration->seconds duration)
 106   "Return the number of seconds represented by DURATION, a 'time-duration'
 107 object, as an inexact number."
 108   (+ (time-second duration)
 109      (/ (time-nanosecond duration) 1e9)))
 110
 111 (define (seconds->string duration)
 112   "Given DURATION in seconds, return a string representing it in 'mm:ss' or
 113 'hh:mm:ss' format, as needed."
 114   (if (not (number? duration))
 115       "00:00"
 116       (let* ((total-seconds (nearest-exact-integer duration))
 117              (extra-seconds (modulo total-seconds 3600))
 118              (num-hours     (quotient total-seconds 3600))
 119              (hours         (and (positive? num-hours) num-hours))
 120              (mins          (quotient extra-seconds 60))
 121              (secs          (modulo extra-seconds 60)))
 122         (format #f "~@[~2,'0d:~]~2,'0d:~2,'0d" hours mins secs))))
 123
 124 (define (byte-count->string size)
 125   "Given SIZE in bytes, return a string representing it in a human-readable
 126 way."
 127   (let ((KiB 1024.)
 128         (MiB (expt 1024. 2))
 129         (GiB (expt 1024. 3))
 130         (TiB (expt 1024. 4)))
 131     (cond
 132      ((< size KiB) (format #f "~dB"     (nearest-exact-integer size)))
 133      ((< size MiB) (format #f "~dKiB"   (nearest-exact-integer (/ size KiB))))
 134      ((< size GiB) (format #f "~,1fMiB" (/ size MiB)))
 135      ((< size TiB) (format #f "~,2fGiB" (/ size GiB)))
 136      (else         (format #f "~,3fTiB" (/ size TiB))))))
 137
 138 (define (string-pad-middle left right len)
 139   "Combine LEFT and RIGHT with enough padding in the middle so that the
 140 resulting string has length at least LEN (it may overflow).  If the string
 141 does not overflow, the last char in RIGHT will be flush with the LEN
 142 column."
 143   (let* ((total-used (+ (string-length left)
 144                         (string-length right)))
 145          (num-spaces (max 1 (- len total-used)))
 146          (padding    (make-string num-spaces #\space)))
 147     (string-append left padding right)))
 148
 149 (define (rate-limited proc interval)
 150   "Return a procedure that will forward the invocation to PROC when the time
 151 elapsed since the previous forwarded invocation is greater or equal to
 152 INTERVAL (a time-duration object), otherwise does nothing and returns #f."
 153   (let ((previous-at #f))
 154     (lambda args
 155       (let* ((now (current-time time-monotonic))
 156              (forward-invocation (lambda ()
 157                                    (set! previous-at now)
 158                                    (apply proc args))))
 159         (if previous-at
 160             (let ((elapsed (time-difference now previous-at)))
 161               (if (time>=? elapsed interval)
 162                   (forward-invocation)
 163                   #f))
 164             (forward-invocation))))))
 165
 166 (define current-terminal-columns
 167   ;; Number of columns of the terminal.
 168   (make-parameter 80))
 169
 170 (define* (progress-bar % #:optional (bar-width 20))
 171   "Return % as a string representing an ASCII-art progress bar.  The total
 172 width of the bar is BAR-WIDTH."
 173   (let* ((bar-width (max 3 (- bar-width 2)))
 174          (fraction (/ % 100))
 175          (filled   (inexact->exact (floor (* fraction bar-width))))
 176          (empty    (- bar-width filled)))
 177     (format #f "[~a~a]"
 178             (make-string filled #\#)
 179             (make-string empty #\space))))
 180
 181 (define (erase-current-line port)
 182   "Write an ANSI erase-current-line sequence to PORT to erase the whole line and
 183 move the cursor to the beginning of the line."
 184   (display "\r\x1b[K" port))
 185
 186 (define* (progress-reporter/file file size
 187                                  #:optional (log-port (current-output-port))
 188                                  #:key (abbreviation basename))
 189   "Return a <progress-reporter> object to show the progress of FILE's download,
 190 which is SIZE bytes long.  The progress report is written to LOG-PORT, with
 191 ABBREVIATION used to shorten FILE for display."
 192   (let ((start-time (current-time time-monotonic))
 193         (transferred 0))
 194     (define (render)
 195       "Write the progress report to LOG-PORT."
 196       (define elapsed
 197         (duration->seconds
 198          (time-difference (current-time time-monotonic) start-time)))
 199       (if (number? size)
 200           (let* ((%  (* 100.0 (/ transferred size)))
 201                  (throughput (/ transferred elapsed))
 202                  (left       (format #f " ~a  ~a"
 203                                      (abbreviation 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"
 216                                      (abbreviation file)))
 217                  (right      (format #f "~a/s ~a | ~a transferred"
 218                                      (byte-count->string throughput)
 219                                      (seconds->string elapsed)
 220                                      (byte-count->string transferred))))
 221             (erase-current-line log-port)
 222             (display (string-pad-middle left right
 223                                         (current-terminal-columns))
 224                      log-port)
 225             (force-output log-port))))
 226
 227     (progress-reporter
 228      (start render)
 229      ;; Report the progress every 300ms or longer.
 230      (report
 231       (let ((rate-limited-render
 232              (rate-limited render (make-time time-monotonic 300000000 0))))
 233         (lambda (value)
 234           (set! transferred value)
 235           (rate-limited-render))))
 236      ;; Don't miss the last report.
 237      (stop render))))
 238
 239 (define* (progress-reporter/bar total
 240                                 #:optional
 241                                 (prefix "")
 242                                 (port (current-error-port)))
 243   "Return a reporter that shows a progress bar every time one of the TOTAL
 244 tasks is performed.  Write PREFIX at the beginning of the line."
 245   (define done 0)
 246
 247   (define (report-progress)
 248     (set! done (+ 1 done))
 249     (unless (> done total)
 250       (let* ((ratio (* 100. (/ done total))))
 251         (erase-current-line port)
 252         (if (string-null? prefix)
 253             (display (progress-bar ratio (current-terminal-columns)) port)
 254             (let ((width (- (current-terminal-columns)
 255                             (string-length prefix) 3)))
 256               (display prefix port)
 257               (display "  " port)
 258               (display (progress-bar ratio width) port)))
 259         (force-output port))))
 260
 261   (progress-reporter
 262    (start (lambda ()
 263             (set! done 0)))
 264    (report report-progress)
 265    (stop (lambda ()
 266            (erase-current-line port)
 267            (unless (string-null? prefix)
 268              (display prefix port)
 269              (newline port))
 270            (force-output port)))))
 271
 272 ;; TODO: replace '(@ (guix build utils) dump-port))'.
 273 (define* (dump-port* in out
 274                      #:key (buffer-size 16384)
 275                      (reporter progress-reporter/silent))
 276   "Read as much data as possible from IN and write it to OUT, using chunks of
 277 BUFFER-SIZE bytes.  After each successful transfer of BUFFER-SIZE bytes or
 278 less, report the total number of bytes transferred to the REPORTER, which
 279 should be a <progress-reporter> object."
 280   (define buffer
 281     (make-bytevector buffer-size))
 282
 283   (call-with-progress-reporter reporter
 284     (lambda (report)
 285       (let loop ((total 0)
 286                  (bytes (get-bytevector-n! in buffer 0 buffer-size)))
 287         (or (eof-object? bytes)
 288             (let ((total (+ total bytes)))
 289               (put-bytevector out buffer 0 bytes)
 290               (report total)
 291               (loop total (get-bytevector-n! in buffer 0 buffer-size))))))))