ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2025-01-13 06:36:37 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

download: Abbreviate URLs when displaying the progress report.

Browse source 
* guix/build/download.scm (uri-abbreviation): New procedure.
  (ftp-fetch, http-fetch): Use it instead of `uri->string' when calling
  `progress-proc'.  Reported by Andreas Enge.
This commit is contained in:
Ludovic Courtès 2013-01-11 15:41:58 +01:00
parent ab6522aeb0
commit 28e5560421
1 changed files with 21 additions and 2 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
guix/build/download.scm
View file

@ -55,6 +55,25 @@ (define* (progress-proc file size #:optional (log-port (current-output-port)))
(flush-output-port log-port)
(cont))))
(define* (uri-abbreviation uri #:optional (max-length 42))
"If URI's string representation is larger than MAX-LENGTH, return an
abbreviation of URI showing the scheme, host, and basename of the file."
(define uri-as-string
(uri->string uri))
(define (elide-path)
(let ((path (uri-path uri)))
(string-append (symbol->string (uri-scheme uri))
"://" (uri-host uri)
(string-append "/.../" (basename path)))))
(if (> (string-length uri-as-string) max-length)
(let ((short (elide-path)))
(if (< (string-length short) (string-length uri-as-string))
short
uri-as-string))
uri-as-string))
(define (ftp-fetch uri file)
"Fetch data from URI and write it to FILE. Return FILE on success."
(let* ((conn (ftp-open (uri-host uri)))
@ -65,7 +84,7 @@ (define (ftp-fetch uri file)
(lambda (out)
(dump-port in out
#:buffer-size 65536 ; don't flood the log
#:progress (progress-proc (uri->string uri) size))))
#:progress (progress-proc (uri-abbreviation uri) size))))
(ftp-close conn))
(newline)
@ -150,7 +169,7 @@ (define (http-fetch uri file)
(begin
(dump-port bv-or-port p
#:buffer-size 65536 ; don't flood the log
#:progress (progress-proc (uri->string uri)
#:progress (progress-proc (uri-abbreviation uri)
size))
(newline))
(put-bytevector p bv-or-port))))