Merge branch 'master' into core-updates

2 files changed, 105 insertions, 64 deletions

diff --git a/guix/build/download.scm b/guix/build/download.scm
index 6e85174bc9..d362fc1f26 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -36,8 +36,10 @@
             resolve-uri-reference
             maybe-expand-mirrors
             url-fetch
+            byte-count->string
             progress-proc
-            uri-abbreviation))
+            uri-abbreviation
+            store-path-abbreviation))
 
 ;;; Commentary:
 ;;;
@@ -49,6 +51,11 @@
   ;; Size of the HTTP receive buffer.
   65536)
 
+(define (nearest-exact-integer x)
+  "Given a real number X, return the nearest exact integer, with ties going to
+the nearest exact even integer."
+  (inexact->exact (round x)))
+
 (define (duration->seconds duration)
   "Return the number of seconds represented by DURATION, a 'time-duration'
 object, as an inexact number."
@@ -56,16 +63,17 @@ object, as an inexact number."
      (/ (time-nanosecond duration) 1e9)))
 
 (define (seconds->string duration)
-  "Given DURATION in seconds, return a string representing it in 'hh:mm:ss'
-format."
+  "Given DURATION in seconds, return a string representing it in 'mm:ss' or
+'hh:mm:ss' format, as needed."
   (if (not (number? duration))
-      "00:00:00"
-      (let* ((total-seconds (inexact->exact (round duration)))
+      "00:00"
+      (let* ((total-seconds (nearest-exact-integer duration))
              (extra-seconds (modulo total-seconds 3600))
-             (hours         (quotient total-seconds 3600))
+             (num-hours     (quotient total-seconds 3600))
+             (hours         (and (positive? num-hours) num-hours))
              (mins          (quotient extra-seconds 60))
              (secs          (modulo extra-seconds 60)))
-        (format #f "~2,'0d:~2,'0d:~2,'0d" hours mins secs))))
+        (format #f "~@[~2,'0d:~]~2,'0d:~2,'0d" hours mins secs))))
 
 (define (byte-count->string size)
   "Given SIZE in bytes, return a string representing it in a human-readable
@@ -75,8 +83,8 @@ way."
         (GiB (expt 1024. 3))
         (TiB (expt 1024. 4)))
     (cond
-     ((< size KiB) (format #f "~dB" (inexact->exact size)))
-     ((< size MiB) (format #f "~dKiB" (inexact->exact (round (/ size KiB)))))
+     ((< size KiB) (format #f "~dB"     (nearest-exact-integer size)))
+     ((< size MiB) (format #f "~dKiB"   (nearest-exact-integer (/ size KiB))))
      ((< size GiB) (format #f "~,1fMiB" (/ size MiB)))
      ((< size TiB) (format #f "~,2fGiB" (/ size GiB)))
      (else         (format #f "~,3fTiB" (/ size TiB))))))
@@ -91,10 +99,33 @@ width of the bar is BAR-WIDTH."
             (make-string filled #\#)
             (make-string empty #\space))))
 
-(define* (progress-proc file size #:optional (log-port (current-output-port)))
+(define (string-pad-middle left right len)
+  "Combine LEFT and RIGHT with enough padding in the middle so that the
+resulting string has length at least LEN.  This right justifies RIGHT."
+  (string-append left
+                 (string-pad right (max 0 (- len (string-length left))))))
+
+(define (store-url-abbreviation url)
+  "Return a friendlier version of URL for display."
+  (let ((store-path (string-append (%store-directory) "/" (basename url))))
+    ;; Take advantage of the implementation for store paths.
+    (store-path-abbreviation store-path)))
+
+(define* (store-path-abbreviation store-path #:optional (prefix-length 6))
+  "Return an abbreviation of STORE-PATH for display, showing PREFIX-LENGTH
+characters of the hash."
+  (let ((base (basename store-path)))
+    (string-append (string-take base prefix-length)
+                   "…"
+                   (string-drop base 32))))
+
+(define* (progress-proc file size
+                        #:optional (log-port (current-output-port))
+                        #:key (abbreviation identity))
   "Return a procedure to show the progress of FILE's download, which is SIZE
 bytes long.  The returned procedure is suitable for use as an argument to
-`dump-port'.  The progress report is written to LOG-PORT."
+`dump-port'.  The progress report is written to LOG-PORT, with ABBREVIATION
+used to shorten FILE for display."
   ;; XXX: Because of <http://bugs.gnu.org/19939> this procedure is often not
   ;; called as frequently as we'd like too; this is especially bad with Nginx
   ;; on hydra.gnu.org, which returns whole nars as a single chunk.
@@ -118,31 +149,31 @@ bytes long.  The returned procedure is suitable for use as an argument to
                                      (/ transferred elapsed)
                                      0))
                      (left       (format #f " ~a  ~a"
-                                         (basename file)
+                                         (abbreviation file)
                                          (byte-count->string size)))
                      (right      (format #f "~a/s ~a ~a~6,1f%"
                                          (byte-count->string throughput)
                                          (seconds->string elapsed)
-                                         (progress-bar %) %))
-                     ;; TODO: Make this adapt to the actual terminal width.
-                     (cols       80)
-                     (num-spaces (max 1 (- cols (+ (string-length left)
-                                                   (string-length right)))))
-                     (gap        (make-string num-spaces #\space)))
-                (format log-port "~a~a~a" left gap right)
+                                         (progress-bar %) %)))
+                ;; TODO: Make this adapt to the actual terminal width.
+                (display (string-pad-middle left right 80) log-port)
                 (display #\cr log-port)
                 (flush-output-port log-port)
                 (cont))))
           (lambda (transferred cont)
             (with-elapsed-time elapsed
-              (let ((throughput (if elapsed
-                                    (/ transferred elapsed)
-                                    0)))
+              (let* ((throughput (if elapsed
+                                     (/ transferred elapsed)
+                                     0))
+                     (left       (format #f " ~a"
+                                         (abbreviation file)))
+                     (right      (format #f "~a/s ~a | ~a transferred"
+                                         (byte-count->string throughput)
+                                         (seconds->string elapsed)
+                                         (byte-count->string transferred))))
+                ;; TODO: Make this adapt to the actual terminal width.
+                (display (string-pad-middle left right 80) log-port)
                 (display #\cr log-port)
-                (format log-port "~a\t~a transferred (~a/s)"
-                        file
-                        (byte-count->string transferred)
-                        (byte-count->string throughput))
                 (flush-output-port log-port)
                 (cont))))))))
 
diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm
index 4184ccc9ac..2685da1a72 100644
--- a/guix/build/ruby-build-system.scm
+++ b/guix/build/ruby-build-system.scm
@@ -41,53 +41,63 @@ directory."
     ((file-name . _) file-name)
     (() (error "No files matching pattern: " pattern))))
 
+(define gnu:unpack (assq-ref gnu:%standard-phases 'unpack))
+
+(define (gem-archive? file-name)
+  (string-match "^.*\\.gem$" file-name))
+
 (define* (unpack #:key source #:allow-other-keys)
   "Unpack the gem SOURCE and enter the resulting directory."
-  (and (zero? (system* "gem" "unpack" source))
-       ;; The unpacked gem directory is named the same as the archive, sans
-       ;; the ".gem" extension.  It is renamed to simply "gem" in an effort to
-       ;; keep file names shorter to avoid UNIX-domain socket file names and
-       ;; shebangs that exceed the system's fixed maximum length when running
-       ;; test suites.
-       (let ((dir (match:substring (string-match "^(.*)\\.gem$"
-                                                 (basename source))
-                                   1)))
-         (rename-file dir "gem")
-         (chdir "gem")
-         #t)))
+  (if (gem-archive? source)
+      (and (zero? (system* "gem" "unpack" source))
+           ;; The unpacked gem directory is named the same as the archive,
+           ;; sans the ".gem" extension.  It is renamed to simply "gem" in an
+           ;; effort to keep file names shorter to avoid UNIX-domain socket
+           ;; file names and shebangs that exceed the system's fixed maximum
+           ;; length when running test suites.
+           (let ((dir (match:substring (string-match "^(.*)\\.gem$"
+                                                     (basename source))
+                                       1)))
+             (rename-file dir "gem")
+             (chdir "gem")
+             #t))
+      ;; Use GNU unpack strategy for things that aren't gem archives.
+      (gnu:unpack #:source source)))
 
 (define* (build #:key source #:allow-other-keys)
   "Build a new gem using the gemspec from the SOURCE gem."
+  (define (first-gemspec)
+    (first-matching-file "\\.gemspec$"))
 
   ;; Remove the original gemspec, if present, and replace it with a new one.
   ;; This avoids issues with upstream gemspecs requiring tools such as git to
   ;; generate the files list.
-  (let ((gemspec (or (false-if-exception
-                      (first-matching-file "\\.gemspec$"))
-                     ;; Make new gemspec if one wasn't shipped.
-                     ".gemspec")))
-
-    (when (file-exists? gemspec) (delete-file gemspec))
-
-    ;; Extract gemspec from source gem.
-    (let ((pipe (open-pipe* OPEN_READ "gem" "spec" "--ruby" source)))
-      (dynamic-wind
-        (const #t)
-        (lambda ()
-          (call-with-output-file gemspec
-            (lambda (out)
-              ;; 'gem spec' writes to stdout, but 'gem build' only reads
-              ;; gemspecs from a file, so we redirect the output to a file.
-              (while (not (eof-object? (peek-char pipe)))
-                (write-char (read-char pipe) out))))
-          #t)
-        (lambda ()
-          (close-pipe pipe))))
-
-    ;; Build a new gem from the current working directory.  This also allows any
-    ;; dynamic patching done in previous phases to be present in the installed
-    ;; gem.
-    (zero? (system* "gem" "build" gemspec))))
+  (when (gem-archive? source)
+    (let ((gemspec (or (false-if-exception (first-gemspec))
+                       ;; Make new gemspec if one wasn't shipped.
+                       ".gemspec")))
+
+      (when (file-exists? gemspec) (delete-file gemspec))
+
+      ;; Extract gemspec from source gem.
+      (let ((pipe (open-pipe* OPEN_READ "gem" "spec" "--ruby" source)))
+        (dynamic-wind
+          (const #t)
+          (lambda ()
+            (call-with-output-file gemspec
+              (lambda (out)
+                ;; 'gem spec' writes to stdout, but 'gem build' only reads
+                ;; gemspecs from a file, so we redirect the output to a file.
+                (while (not (eof-object? (peek-char pipe)))
+                  (write-char (read-char pipe) out))))
+            #t)
+          (lambda ()
+            (close-pipe pipe))))))
+
+  ;; Build a new gem from the current working directory.  This also allows any
+  ;; dynamic patching done in previous phases to be present in the installed
+  ;; gem.
+  (zero? (system* "gem" "build" (first-gemspec))))
 
 (define* (check #:key tests? test-target #:allow-other-keys)
   "Run the gem's test suite rake task TEST-TARGET.  Skip the tests if TESTS?