download: Abbreviate URLs when displaying the progress report.

* 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.

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))))