nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

download: Don't report the progress too fast. 

* guix/utils.scm (<progress-reporter>): New record type.
(call-with-progress-reporter): New procedure.
* guix/build/download.scm (dump-port*, rate-limited, progress-reporter/file):
New procedures.
(ftp-fetch, http-fetch): Use 'dump-port*'.
(progress-proc): Remove procedure.
* guix/scripts/substitute.scm (progress-report-port): Rewrite in terms of
<progress-reporter>.
(process-substitution): Adjust accordingly.
This commit is contained in:
宋文武 2017-09-16 14:10:18 -06:00
parent f1b65d0dd9
commit 798648515b
No known key found for this signature in database
GPG Key ID: 26525665AE727D37
3 changed files with 161 additions and 99 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

174
guix/build/download.scm
View File

@ -27,6 +27,7 @@
#:use-module (guix base64) #:use-module (guix base64)
#:use-module (guix ftp-client) #:use-module (guix ftp-client)
#:use-module (guix build utils) #:use-module (guix build utils)
#:use-module (guix utils)
#:use-module (rnrs io ports) #:use-module (rnrs io ports)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
@ -45,7 +46,7 @@
url-fetch url-fetch
byte-count->string byte-count->string
current-terminal-columns current-terminal-columns
progress-proc progress-reporter/file
uri-abbreviation uri-abbreviation
nar-uri-abbreviation nar-uri-abbreviation
store-path-abbreviation)) store-path-abbreviation))
@ -148,65 +149,97 @@ Otherwise return STORE-PATH."
(define time-monotonic time-tai)) (define time-monotonic time-tai))
(else #t)) (else #t))
(define* (progress-proc file size
#:optional (log-port (current-output-port)) ;; TODO: replace '(@ (guix build utils) dump-port))'.
#:key (abbreviation basename)) (define* (dump-port* in out
"Return a procedure to show the progress of FILE's download, which is SIZE #:key (buffer-size 16384)
bytes long. The returned procedure is suitable for use as an argument to (reporter (make-progress-reporter noop noop noop)))
`dump-port'. The progress report is written to LOG-PORT, with ABBREVIATION "Read as much data as possible from IN and write it to OUT, using chunks of
used to shorten FILE for display." BUFFER-SIZE bytes. After each successful transfer of BUFFER-SIZE bytes or
;; XXX: Because of <http://bugs.gnu.org/19939> this procedure is often not less, report the total number of bytes transferred to the REPORTER, which
;; called as frequently as we'd like too; this is especially bad with Nginx should be a <progress-reporter> object."
;; on hydra.gnu.org, which returns whole nars as a single chunk. (define buffer
(let ((start-time #f)) (make-bytevector buffer-size))
(let-syntax ((with-elapsed-time
(syntax-rules () (call-with-progress-reporter reporter
((_ elapsed body ...) (lambda (report)
(let* ((now (current-time time-monotonic)) (let loop ((total 0)
(elapsed (and start-time (bytes (get-bytevector-n! in buffer 0 buffer-size)))
(duration->seconds (or (eof-object? bytes)
(time-difference now (let ((total (+ total bytes)))
start-time))))) (put-bytevector out buffer 0 bytes)
(unless start-time (report total)
(set! start-time now)) (loop total (get-bytevector-n! in buffer 0 buffer-size))))))))
body ...)))))
(define (rate-limited proc interval)
"Return a procedure that will forward the invocation to PROC when the time
elapsed since the previous forwarded invocation is greater or equal to
INTERVAL (a time-duration object), otherwise does nothing and returns #f."
(let ((previous-at #f))
(lambda args
(let* ((now (current-time time-monotonic))
(forward-invocation (lambda ()
(set! previous-at now)
(apply proc args))))
(if previous-at
(let ((elapsed (time-difference now previous-at)))
(if (time>=? elapsed interval)
(forward-invocation)
#f))
(forward-invocation))))))
(define* (progress-reporter/file file size
#:optional (log-port (current-output-port))
#:key (abbreviation basename))
"Return a <progress-reporter> object to show the progress of FILE's download,
which is SIZE bytes long. The progress report is written to LOG-PORT, with
ABBREVIATION used to shorten FILE for display."
(let ((start-time (current-time time-monotonic))
(transferred 0))
(define (render)
"Write the progress report to LOG-PORT."
(define elapsed
(duration->seconds
(time-difference (current-time time-monotonic) start-time)))
(if (number? size) (if (number? size)
(lambda (transferred cont) (let* ((% (* 100.0 (/ transferred size)))
(with-elapsed-time elapsed (throughput (/ transferred elapsed))
(let* ((% (* 100.0 (/ transferred size))) (left (format #f " ~a ~a"
(throughput (if elapsed (abbreviation file)
(/ transferred elapsed) (byte-count->string size)))
0)) (right (format #f "~a/s ~a ~a~6,1f%"
(left (format #f " ~a ~a" (byte-count->string throughput)
(abbreviation file) (seconds->string elapsed)
(byte-count->string size))) (progress-bar %) %)))
(right (format #f "~a/s ~a ~a~6,1f%" (display "\r\x1b[K" log-port)
(byte-count->string throughput) (display (string-pad-middle left right
(seconds->string elapsed) (current-terminal-columns))
(progress-bar %) %))) log-port)
(display "\r\x1b[K" log-port) (flush-output-port log-port))
(display (string-pad-middle left right (let* ((throughput (/ transferred elapsed))
(current-terminal-columns)) (left (format #f " ~a"
log-port) (abbreviation file)))
(flush-output-port log-port) (right (format #f "~a/s ~a | ~a transferred"
(cont)))) (byte-count->string throughput)
(lambda (transferred cont) (seconds->string elapsed)
(with-elapsed-time elapsed (byte-count->string transferred))))
(let* ((throughput (if elapsed (display "\r\x1b[K" log-port)
(/ transferred elapsed) (display (string-pad-middle left right
0)) (current-terminal-columns))
(left (format #f " ~a" log-port)
(abbreviation file))) (flush-output-port log-port))))
(right (format #f "~a/s ~a | ~a transferred"
(byte-count->string throughput) (progress-reporter
(seconds->string elapsed) (start render)
(byte-count->string transferred)))) ;; Report the progress every 300ms or longer.
(display "\r\x1b[K" log-port) (report
(display (string-pad-middle left right (let ((rate-limited-render
(current-terminal-columns)) (rate-limited render (make-time time-monotonic 300000000 0))))
log-port) (lambda (value)
(flush-output-port log-port) (set! transferred value)
(cont)))))))) (rate-limited-render))))
;; Don't miss the last report.
(stop render))))
(define* (uri-abbreviation uri #:optional (max-length 42)) (define* (uri-abbreviation uri #:optional (max-length 42))
"If URI's string representation is larger than MAX-LENGTH, return an "If URI's string representation is larger than MAX-LENGTH, return an
@ -264,9 +297,10 @@ out if the connection could not be established in less than TIMEOUT seconds."
(dirname (uri-path uri))))) (dirname (uri-path uri)))))
(call-with-output-file file (call-with-output-file file
(lambda (out) (lambda (out)
(dump-port in out (dump-port* in out
#:buffer-size %http-receive-buffer-size #:buffer-size %http-receive-buffer-size
#:progress (progress-proc (uri-abbreviation uri) size)))) #:reporter (progress-reporter/file
(uri-abbreviation uri) size))))
(ftp-close conn)) (ftp-close conn))
(newline) (newline)
@ -755,10 +789,10 @@ certificates; otherwise simply ignore them."
(lambda (p) (lambda (p)
(if (port? bv-or-port) (if (port? bv-or-port)
(begin (begin
(dump-port bv-or-port p (dump-port* bv-or-port p
#:buffer-size %http-receive-buffer-size #:buffer-size %http-receive-buffer-size
#:progress (progress-proc (uri-abbreviation uri) #:reporter (progress-reporter/file
size)) (uri-abbreviation uri) size))
(newline)) (newline))
(put-bytevector p bv-or-port)))) (put-bytevector p bv-or-port))))
file)) file))
@ -863,8 +897,8 @@ otherwise simply ignore them."
hashes)) hashes))
content-addressed-mirrors)) content-addressed-mirrors))
;; Make this unbuffered so 'progress-proc' works as expected. _IOLBF means ;; Make this unbuffered so 'progress-report/file' works as expected. _IOLBF
;; '\n', not '\r', so it's not appropriate here. ;; means '\n', not '\r', so it's not appropriate here.
(setvbuf (current-output-port) _IONBF) (setvbuf (current-output-port) _IONBF)
(setvbuf (current-error-port) _IOLBF) (setvbuf (current-error-port) _IOLBF)
@ -879,8 +913,4 @@ otherwise simply ignore them."
file url) file url)
#f)))) #f))))
;;; Local Variables:
;;; eval: (put 'with-elapsed-time 'scheme-indent-function 1)
;;; End:
;;; download.scm ends here ;;; download.scm ends here

54
guix/scripts/substitute.scm
View File

@ -34,7 +34,8 @@
#:use-module ((guix build utils) #:select (mkdir-p dump-port)) #:use-module ((guix build utils) #:select (mkdir-p dump-port))
#:use-module ((guix build download) #:use-module ((guix build download)
#:select (current-terminal-columns #:select (current-terminal-columns
progress-proc uri-abbreviation nar-uri-abbreviation progress-reporter/file
uri-abbreviation nar-uri-abbreviation
(open-connection-for-uri (open-connection-for-uri
. guix:open-connection-for-uri) . guix:open-connection-for-uri)
close-connection close-connection
@ -814,23 +815,25 @@ was found."
(= (string-length file) 32))))) (= (string-length file) 32)))))
(narinfo-cache-directories directory))) (narinfo-cache-directories directory)))
(define (progress-report-port report-progress port) (define (progress-report-port reporter port)
"Return a port that calls REPORT-PROGRESS every time something is read from "Return a port that continuously reports the bytes read from PORT using
PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by REPORTER, which should be a <progress-reporter> object."
`progress-proc'." (match reporter
(define total 0) (($ <progress-reporter> start report stop)
(define (read! bv start count) (let* ((total 0)
(let ((n (match (get-bytevector-n! port bv start count) (read! (lambda (bv start count)
((? eof-object?) 0) (let ((n (match (get-bytevector-n! port bv start count)
(x x)))) ((? eof-object?) 0)
(set! total (+ total n)) (x x))))
(report-progress total (const n)) (set! total (+ total n))
;; XXX: We're not in control, so we always return anyway. (report total)
n)) n))))
(start)
(make-custom-binary-input-port "progress-port-proc" (make-custom-binary-input-port "progress-port-proc"
read! #f #f read! #f #f
(cut close-connection port))) (lambda ()
(close-connection port)
(stop)))))))
(define-syntax with-networking (define-syntax with-networking
(syntax-rules () (syntax-rules ()
@ -947,12 +950,11 @@ DESTINATION as a nar file. Verify the substitute against ACL."
(dl-size (or download-size (dl-size (or download-size
(and (equal? comp "none") (and (equal? comp "none")
(narinfo-size narinfo)))) (narinfo-size narinfo))))
(progress (progress-proc (uri->string uri) (reporter (progress-reporter/file
dl-size (uri->string uri) dl-size
(current-error-port) (current-error-port)
#:abbreviation #:abbreviation nar-uri-abbreviation)))
nar-uri-abbreviation))) (progress-report-port reporter raw)))
(progress-report-port progress raw)))
((input pids) ((input pids)
(decompressed-port (and=> (narinfo-compression narinfo) (decompressed-port (and=> (narinfo-compression narinfo)
string->symbol) string->symbol)
@ -961,8 +963,8 @@ DESTINATION as a nar file. Verify the substitute against ACL."
(restore-file input destination) (restore-file input destination)
(close-port input) (close-port input)
;; Skip a line after what 'progress-proc' printed, and another one to ;; Skip a line after what 'progress-reporter/file' printed, and another
;; visually separate substitutions. ;; one to visually separate substitutions.
(display "\n\n" (current-error-port)) (display "\n\n" (current-error-port))
(every (compose zero? cdr waitpid) pids)))) (every (compose zero? cdr waitpid) pids))))

32
guix/utils.scm
View File

@ -33,6 +33,7 @@
#:autoload (rnrs io ports) (make-custom-binary-input-port) #:autoload (rnrs io ports) (make-custom-binary-input-port)
#:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!)) #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!))
#:use-module (guix memoization) #:use-module (guix memoization)
#:use-module (guix records)
#:use-module ((guix build utils) #:select (dump-port mkdir-p)) #:use-module ((guix build utils) #:select (dump-port mkdir-p))
#:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync)) #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync))
#:use-module (ice-9 format) #:use-module (ice-9 format)
@ -94,7 +95,13 @@
call-with-decompressed-port call-with-decompressed-port
compressed-output-port compressed-output-port
call-with-compressed-output-port call-with-compressed-output-port
canonical-newline-port)) canonical-newline-port
<progress-reporter>
progress-reporter
make-progress-reporter
progress-reporter?
call-with-progress-reporter))
;;; ;;;
@ -747,3 +754,26 @@ a location object."
`((line . ,(and=> (location-line loc) 1-)) `((line . ,(and=> (location-line loc) 1-))
(column . ,(location-column loc)) (column . ,(location-column loc))
(filename . ,(location-file loc)))) (filename . ,(location-file loc))))
;;;
;;; Progress reporter.
;;;
(define-record-type* <progress-reporter>
progress-reporter make-progress-reporter progress-reporter?
(start progress-reporter-start) ; thunk
(report progress-reporter-report) ; procedure
(stop progress-reporter-stop)) ; thunk
(define (call-with-progress-reporter reporter proc)
"Start REPORTER for progress reporting, and call @code{(@var{proc} report)}
with the resulting report procedure. When @var{proc} returns, the REPORTER is
stopped."
(match reporter
(($ <progress-reporter> start report stop)
(dynamic-wind start (lambda () (proc report)) stop))))
;;; Local Variables:
;;; eval: (put 'call-with-progress-reporter 'scheme-indent-function 1)
;;; End: