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

download: Report the progress of HTTP downloads. 

* guix/build/download.scm (http-fetch): Rename `bv' to `bv-or-port'.
  Use `http-get*' followed by `dump-port' when the former is available,
  and pass a progress procedure to `dump-port'.
This commit is contained in:
Ludovic Courtès 2013-01-06 18:36:50 +01:00
parent e47bac7902
commit e66ca1a5a8
1 changed files with 20 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
guix/build/download.scm
View File

@ -126,20 +126,34 @@ which is not available during bootstrap."
(define (http-fetch uri file) (define (http-fetch uri file)
"Fetch data from URI and write it to FILE. Return FILE on success." "Fetch data from URI and write it to FILE. Return FILE on success."
;; FIXME: Use a variant of `http-get' that returns a port instead of
;; loading everything in memory.
(let*-values (((connection) (let*-values (((connection)
(open-connection-for-uri uri)) (open-connection-for-uri uri))
((resp bv) ((resp bv-or-port)
(http-get uri #:port connection #:decode-body? #f)) ;; XXX: `http-get*' was introduced in 2.0.7. We know
;; we're using it within the chroot, but
;; `guix-download' might be using a different version.
;; So keep this compatibility hack for now.
(if (module-defined? (resolve-interface '(web client))
'http-get*)
(http-get* uri #:port connection #:decode-body? #f)
(http-get uri #:port connection #:decode-body? #f)))
((code) ((code)
(response-code resp))) (response-code resp))
((size)
(response-content-length resp)))
(case code (case code
((200) ; OK ((200) ; OK
(begin (begin
(call-with-output-file file (call-with-output-file file
(lambda (p) (lambda (p)
(put-bytevector p bv))) (if (port? bv-or-port)
(begin
(dump-port bv-or-port p
#:buffer-size 65536 ; don't flood the log
#:progress (progress-proc (uri->string uri)
size))
(newline))
(put-bytevector p bv-or-port))))
file)) file))
((302) ; found (redirection) ((302) ; found (redirection)
(let ((uri (response-location resp))) (let ((uri (response-location resp)))