diff options
| -rw-r--r-- | guix/build/download.scm | 23 |
1 files changed, 21 insertions, 2 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm index 7c48d7bff5..09c62541de 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -55,6 +55,25 @@ argument to `dump-port'. The progress report is written to LOG-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 @@ argument to `dump-port'. The progress report is written to LOG-PORT." (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 @@ which is not available during bootstrap." (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)))) |