02/05: substitute: Better abbreviate substitute URL in progress report.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit cf5e58297d441e5e8f93e104f23eb3d18b2b51c9
Author: Ludovic Courtès <address@hidden>
Date:   Wed Apr 20 23:01:41 2016 +0200

    substitute: Better abbreviate substitute URL in progress report.
    
    Suggested by Danny Milosavljevic <address@hidden>.
    
    * guix/build/download.scm (nar-uri-abbreviation): New procedure.
    * guix/scripts/substitute.scm (process-substitution): Use it instead of
    'store-path-abbreviation'.
---
 guix/build/download.scm     |   12 ++++++++++++
 guix/scripts/substitute.scm |    6 +++---
 2 files changed, 15 insertions(+), 3 deletions(-)

diff --git a/guix/build/download.scm b/guix/build/download.scm
index fe7a453..fec4cec 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -42,6 +42,7 @@
             current-terminal-columns
             progress-proc
             uri-abbreviation
+            nar-uri-abbreviation
             store-path-abbreviation))
 
 ;;; Commentary:
@@ -222,6 +223,17 @@ abbreviation of URI showing the scheme, host, and basename 
of the file."
             uri-as-string))
       uri-as-string))
 
+(define (nar-uri-abbreviation uri)
+  "Abbreviate URI, which is assumed to be the URI of a nar as served by Hydra
+and 'guix publish', something like
+\"http://example.org/nar/1ldrllwbna0aw5z8kpci4fsvbd2w8cw4-texlive-bin-2015\".";
+  (let* ((uri  (if (string? uri) (string->uri uri) uri))
+         (path (basename (uri-path uri))))
+    (if (and (> (string-length path) 33)
+             (char=? (string-ref path 32) #\-))
+        (string-drop path 33)
+        path)))
+
 (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)))
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index db0416b..0f0677f 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -32,7 +32,7 @@
   #:use-module ((guix build utils) #:select (mkdir-p dump-port))
   #:use-module ((guix build download)
                 #:select (current-terminal-columns
-                          progress-proc uri-abbreviation
+                          progress-proc uri-abbreviation nar-uri-abbreviation
                           open-connection-for-uri
                           close-connection
                           store-path-abbreviation byte-count->string))
@@ -896,11 +896,11 @@ DESTINATION as a nar file.  Verify the substitute against 
ACL."
                           (dl-size  (or download-size
                                         (and (equal? comp "none")
                                              (narinfo-size narinfo))))
-                          (progress (progress-proc (uri-abbreviation uri)
+                          (progress (progress-proc (uri->string uri)
                                                    dl-size
                                                    (current-error-port)
                                                    #:abbreviation
-                                                   store-path-abbreviation)))
+                                                   nar-uri-abbreviation)))
                      (progress-report-port progress raw)))
                   ((input pids)
                    (decompressed-port (and=> (narinfo-compression narinfo)