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 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (guix progress)
  21   #:use-module (guix records)
  22   #:use-module (srfi srfi-19)
  23   #:use-module (rnrs io ports)
  24   #:use-module (rnrs bytevectors)
  25   #:use-module (ice-9 format)
  26   #:use-module (ice-9 match)
  27   #:export (<progress-reporter>
  28             progress-reporter
  29             make-progress-reporter
  30             progress-reporter?
  31             call-with-progress-reporter
  32
  33             progress-reporter/silent
  34             progress-reporter/file
  35
  36             byte-count->string
  37             current-terminal-columns
  38
  39             dump-port*))
  40
  41 ;;; Commentary:
  42 ;;;
  43 ;;; Helper to write progress report code for downloads, etc.
  44 ;;;
  45 ;;; Code:
  46
  47 (define-record-type* <progress-reporter>
  48   progress-reporter make-progress-reporter progress-reporter?
  49   (start   progress-reporter-start)     ; thunk
  50   (report  progress-reporter-report)    ; procedure
  51   (stop    progress-reporter-stop))     ; thunk
  52
  53 (define (call-with-progress-reporter reporter proc)
  54   "Start REPORTER for progress reporting, and call @code{(@var{proc} report)}
  55 with the resulting report procedure.  When @var{proc} returns, the REPORTER is
  56 stopped."
  57   (match reporter
  58     (($ <progress-reporter> start report stop)
  59      (dynamic-wind start (lambda () (proc report)) stop))))
  60
  61 (define progress-reporter/silent
  62   (make-progress-reporter noop noop noop))
  63
  64 \f
  65 ;;;
  66 ;;; File download progress report.
  67 ;;;
  68
  69 (cond-expand
  70   (guile-2.2
  71    ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
  72    ;; nanoseconds swapped (fixed in Guile commit 886ac3e).  Work around it.
  73    (define time-monotonic time-tai))
  74   (else #t))
  75
  76 (define (nearest-exact-integer x)
  77   "Given a real number X, return the nearest exact integer, with ties going to
  78 the nearest exact even integer."
  79   (inexact->exact (round x)))
  80
  81 (define (duration->seconds duration)
  82   "Return the number of seconds represented by DURATION, a 'time-duration'
  83 object, as an inexact number."
  84   (+ (time-second duration)
  85      (/ (time-nanosecond duration) 1e9)))
  86
  87 (define (seconds->string duration)
  88   "Given DURATION in seconds, return a string representing it in 'mm:ss' or
  89 'hh:mm:ss' format, as needed."
  90   (if (not (number? duration))
  91       "00:00"
  92       (let* ((total-seconds (nearest-exact-integer duration))
  93              (extra-seconds (modulo total-seconds 3600))
  94              (num-hours     (quotient total-seconds 3600))
  95              (hours         (and (positive? num-hours) num-hours))
  96              (mins          (quotient extra-seconds 60))
  97              (secs          (modulo extra-seconds 60)))
  98         (format #f "~@[~2,'0d:~]~2,'0d:~2,'0d" hours mins secs))))
  99
 100 (define (byte-count->string size)
 101   "Given SIZE in bytes, return a string representing it in a human-readable
 102 way."
 103   (let ((KiB 1024.)
 104         (MiB (expt 1024. 2))
 105         (GiB (expt 1024. 3))
 106         (TiB (expt 1024. 4)))
 107     (cond
 108      ((< size KiB) (format #f "~dB"     (nearest-exact-integer size)))
 109      ((< size MiB) (format #f "~dKiB"   (nearest-exact-integer (/ size KiB))))
 110      ((< size GiB) (format #f "~,1fMiB" (/ size MiB)))
 111      ((< size TiB) (format #f "~,2fGiB" (/ size GiB)))
 112      (else         (format #f "~,3fTiB" (/ size TiB))))))
 113
 114 (define (string-pad-middle left right len)
 115   "Combine LEFT and RIGHT with enough padding in the middle so that the
 116 resulting string has length at least LEN (it may overflow).  If the string
 117 does not overflow, the last char in RIGHT will be flush with the LEN
 118 column."
 119   (let* ((total-used (+ (string-length left)
 120                         (string-length right)))
 121          (num-spaces (max 1 (- len total-used)))
 122          (padding    (make-string num-spaces #\space)))
 123     (string-append left padding right)))
 124
 125 (define (rate-limited proc interval)
 126   "Return a procedure that will forward the invocation to PROC when the time
 127 elapsed since the previous forwarded invocation is greater or equal to
 128 INTERVAL (a time-duration object), otherwise does nothing and returns #f."
 129   (let ((previous-at #f))
 130     (lambda args
 131       (let* ((now (current-time time-monotonic))
 132              (forward-invocation (lambda ()
 133                                    (set! previous-at now)
 134                                    (apply proc args))))
 135         (if previous-at
 136             (let ((elapsed (time-difference now previous-at)))
 137               (if (time>=? elapsed interval)
 138                   (forward-invocation)
 139                   #f))
 140             (forward-invocation))))))
 141
 142 (define current-terminal-columns
 143   ;; Number of columns of the terminal.
 144   (make-parameter 80))
 145
 146 (define* (progress-bar % #:optional (bar-width 20))
 147   "Return % as a string representing an ASCII-art progress bar.  The total
 148 width of the bar is BAR-WIDTH."
 149   (let* ((bar-width (max 3 (- bar-width 2)))
 150          (fraction (/ % 100))
 151          (filled   (inexact->exact (floor (* fraction bar-width))))
 152          (empty    (- bar-width filled)))
 153     (format #f "[~a~a]"
 154             (make-string filled #\#)
 155             (make-string empty #\space))))
 156
 157 (define (erase-in-line port)
 158   "Write an ANSI erase-in-line sequence to PORT to erase the whole line and
 159 move the cursor to the beginning of the line."
 160   (display "\r\x1b[K" port))
 161
 162 (define* (progress-reporter/file file size
 163                                  #:optional (log-port (current-output-port))
 164                                  #:key (abbreviation basename))
 165   "Return a <progress-reporter> object to show the progress of FILE's download,
 166 which is SIZE bytes long.  The progress report is written to LOG-PORT, with
 167 ABBREVIATION used to shorten FILE for display."
 168   (let ((start-time (current-time time-monotonic))
 169         (transferred 0))
 170     (define (render)
 171       "Write the progress report to LOG-PORT."
 172       (define elapsed
 173         (duration->seconds
 174          (time-difference (current-time time-monotonic) start-time)))
 175       (if (number? size)
 176           (let* ((%  (* 100.0 (/ transferred size)))
 177                  (throughput (/ transferred elapsed))
 178                  (left       (format #f " ~a  ~a"
 179                                      (abbreviation file)
 180                                      (byte-count->string size)))
 181                  (right      (format #f "~a/s ~a ~a~6,1f%"
 182                                      (byte-count->string throughput)
 183                                      (seconds->string elapsed)
 184                                      (progress-bar %) %)))
 185             (erase-in-line log-port)
 186             (display (string-pad-middle left right
 187                                         (current-terminal-columns))
 188                      log-port)
 189             (force-output log-port))
 190           (let* ((throughput (/ transferred elapsed))
 191                  (left       (format #f " ~a"
 192                                      (abbreviation file)))
 193                  (right      (format #f "~a/s ~a | ~a transferred"
 194                                      (byte-count->string throughput)
 195                                      (seconds->string elapsed)
 196                                      (byte-count->string transferred))))
 197             (erase-in-line log-port)
 198             (display (string-pad-middle left right
 199                                         (current-terminal-columns))
 200                      log-port)
 201             (force-output log-port))))
 202
 203     (progress-reporter
 204      (start render)
 205      ;; Report the progress every 300ms or longer.
 206      (report
 207       (let ((rate-limited-render
 208              (rate-limited render (make-time time-monotonic 300000000 0))))
 209         (lambda (value)
 210           (set! transferred value)
 211           (rate-limited-render))))
 212      ;; Don't miss the last report.
 213      (stop render))))
 214
 215 ;; TODO: replace '(@ (guix build utils) dump-port))'.
 216 (define* (dump-port* in out
 217                      #:key (buffer-size 16384)
 218                      (reporter progress-reporter/silent))
 219   "Read as much data as possible from IN and write it to OUT, using chunks of
 220 BUFFER-SIZE bytes.  After each successful transfer of BUFFER-SIZE bytes or
 221 less, report the total number of bytes transferred to the REPORTER, which
 222 should be a <progress-reporter> object."
 223   (define buffer
 224     (make-bytevector buffer-size))
 225
 226   (call-with-progress-reporter reporter
 227     (lambda (report)
 228       (let loop ((total 0)
 229                  (bytes (get-bytevector-n! in buffer 0 buffer-size)))
 230         (or (eof-object? bytes)
 231             (let ((total (+ total bytes)))
 232               (put-bytevector out buffer 0 bytes)
 233               (report total)
 234               (loop total (get-bytevector-n! in buffer 0 buffer-size))))))))