From dc0f74e5fc26977a3ee6c4f2aa74a141f4359982 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 18 Jan 2017 23:21:29 +0100
Subject: Add (guix status) and use it for pretty colored output.

* guix/progress.scm (progress-reporter/trace): New procedure.
(%progress-interval): New variable.
(progress-reporter/file): Use it.
* guix/scripts/build.scm (set-build-options-from-command-line): Pass
 #:print-extended-build-trace?.
(%default-options): Add 'print-extended-build-trace?'.
(guix-build): Parameterize CURRENT-TERMINAL-COLUMNS.  Use
'build-status-updater'.
* guix/scripts/environment.scm (%default-options): Add
'print-extended-build-trace?'.
(guix-environment): Wrap body in 'with-status-report'.
* guix/scripts/pack.scm (%default-options): Add 'print-build-trace?' and
'print-extended-build-trace?'.
(guix-pack): Wrap body in 'with-status-report'.
* guix/scripts/package.scm (%default-options, guix-package): Likewise.
* guix/scripts/system.scm (%default-options, guix-system): Likewise.
* guix/scripts/pull.scm (%default-options, guix-pull): Likewise.
* guix/scripts/substitute.scm (progress-report-port): Don't call STOP
when TOTAL is zero.
(process-substitution): Add #:print-build-trace? and honor it.
(guix-substitute)[print-build-trace?]: New variable.
Pass #:print-build-trace? to 'process-substitution'.
* guix/status.scm: New file.
* guix/store.scm (set-build-options): Add #:print-extended-build-trace?;
pass it into PAIRS.
(%protocol-version): Bump.
(protocol-version, nix-server-version): New procedures.
(current-store-protocol-version): New variable.
(with-store, build-things): Parameterize it.
* guix/ui.scm (build-output-port): Remove.
(colorize-string): Export.
* po/guix/POTFILES.in: Add guix/status.scm.
* tests/status.scm: New file.
* Makefile.am (SCM_TESTS): Add it.
* nix/libstore/worker-protocol.hh (PROTOCOL_VERSION): Bump to 0x162.
* nix/libstore/build.cc (DerivationGoal::registerOutputs)
(SubstitutionGoal::finished): Print a "@ hash-mismatch" trace before
throwing.
---
 .dir-locals.el                    |   1 +
 Makefile.am                       |   2 +
 guix/progress.scm                 |  38 ++-
 guix/scripts/build.scm            |  13 +-
 guix/scripts/environment.scm      | 116 ++++-----
 guix/scripts/pack.scm             | 142 +++++------
 guix/scripts/package.scm          |  25 +-
 guix/scripts/perform-download.scm |   1 +
 guix/scripts/pull.scm             |  66 ++---
 guix/scripts/substitute.scm       |  42 +++-
 guix/scripts/system.scm           |  11 +-
 guix/status.scm                   | 493 ++++++++++++++++++++++++++++++++++++++
 guix/store.scm                    |  53 +++-
 guix/ui.scm                       | 122 +---------
 nix/libstore/build.cc             |  27 ++-
 nix/libstore/worker-protocol.hh   |   2 +-
 po/guix/POTFILES.in               |   1 +
 tests/status.scm                  | 115 +++++++++
 18 files changed, 939 insertions(+), 331 deletions(-)
 create mode 100644 guix/status.scm
 create mode 100644 tests/status.scm

diff --git a/.dir-locals.el b/.dir-locals.el
index eb99a5bcc1..793117c0ae 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -59,6 +59,7 @@
    (eval . (put 'emacs-substitute-variables 'scheme-indent-function 1))
    (eval . (put 'with-derivation-narinfo 'scheme-indent-function 1))
    (eval . (put 'with-derivation-substitute 'scheme-indent-function 2))
+   (eval . (put 'with-status-report 'scheme-indent-function 1))
 
    (eval . (put 'mlambda 'scheme-indent-function 1))
    (eval . (put 'mlambdaq 'scheme-indent-function 1))
diff --git a/Makefile.am b/Makefile.am
index 5c8639d665..7fd29b90a8 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -131,6 +131,7 @@ MODULES =					\
   guix/svn-download.scm				\
   guix/i18n.scm					\
   guix/ui.scm					\
+  guix/status.scm				\
   guix/build/android-ndk-build-system.scm	\
   guix/build/ant-build-system.scm		\
   guix/build/download.scm			\
@@ -340,6 +341,7 @@ SCM_TESTS =					\
   tests/glob.scm				\
   tests/grafts.scm				\
   tests/ui.scm					\
+  tests/status.scm				\
   tests/records.scm				\
   tests/upstream.scm				\
   tests/combinators.scm				\
diff --git a/guix/progress.scm b/guix/progress.scm
index d4ebb32991..3b9ff408cd 100644
--- a/guix/progress.scm
+++ b/guix/progress.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 Sou Bunnbu <iyzsong@gmail.com>
 ;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com>
-;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -38,8 +38,11 @@
             progress-reporter/silent
             progress-reporter/file
             progress-reporter/bar
+            progress-reporter/trace
 
             display-download-progress
+            erase-current-line
+            progress-bar
             byte-count->string
             current-terminal-columns
 
@@ -220,6 +223,10 @@ throughput."
                  log-port)
         (force-output log-port))))
 
+(define %progress-interval
+  ;; Default interval between subsequent outputs for rate-limited displays.
+  (make-time time-monotonic 200000000 0))
+
 (define* (progress-reporter/file file size
                                  #:optional (log-port (current-output-port))
                                  #:key (abbreviation basename))
@@ -238,8 +245,7 @@ ABBREVIATION used to shorten FILE for display."
      (start render)
      ;; Report the progress every 300ms or longer.
      (report
-      (let ((rate-limited-render
-             (rate-limited render (make-time time-monotonic 300000000 0))))
+      (let ((rate-limited-render (rate-limited render %progress-interval)))
         (lambda (value)
           (set! transferred value)
           (rate-limited-render))))
@@ -279,6 +285,32 @@ tasks is performed.  Write PREFIX at the beginning of the line."
              (newline port))
            (force-output port)))))
 
+(define* (progress-reporter/trace file url size
+                                  #:optional (log-port (current-output-port)))
+  "Like 'progress-reporter/file', but instead of returning human-readable
+progress reports, write \"build trace\" lines to be processed elsewhere."
+  (define (report-progress transferred)
+    (define message
+      (format #f "@ download-progress ~a ~a ~a ~a~%"
+              file url (or size "-") transferred))
+
+    (display message log-port)                    ;should be atomic
+    (flush-output-port log-port))
+
+  (progress-reporter
+   (start (lambda ()
+            (display (format #f "@ download-started ~a ~a ~a~%"
+                             file url (or size "-"))
+                     log-port)))
+   (report (rate-limited report-progress %progress-interval))
+   (stop (lambda ()
+           (report-progress size)
+           (display (format #f "@ download-succeeded ~a ~a ~a~%"
+                            file url
+                            (or (and=> (stat file #f) stat:size)
+                                size))
+                    log-port)))))
+
 ;; TODO: replace '(@ (guix build utils) dump-port))'.
 (define* (dump-port* in out
                      #:key (buffer-size 16384)
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 9d38610633..5a6ba62bc3 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -45,6 +45,9 @@
   #:use-module (srfi srfi-37)
   #:autoload   (gnu packages) (specification->package %package-module-path)
   #:autoload   (guix download) (download-to-store)
+  #:use-module (guix status)
+  #:use-module ((guix progress) #:select (current-terminal-columns))
+  #:use-module ((guix build syscalls) #:select (terminal-columns))
   #:export (%standard-build-options
             set-build-options-from-command-line
             set-build-options-from-command-line*
@@ -390,6 +393,8 @@ options handled by 'set-build-options-from-command-line', and listed in
                      #:max-silent-time (assoc-ref opts 'max-silent-time)
                      #:timeout (assoc-ref opts 'timeout)
                      #:print-build-trace (assoc-ref opts 'print-build-trace?)
+                     #:print-extended-build-trace?
+                     (assoc-ref opts 'print-extended-build-trace?)
                      #:verbosity (assoc-ref opts 'verbosity)))
 
 (define set-build-options-from-command-line*
@@ -499,6 +504,7 @@ options handled by 'set-build-options-from-command-line', and listed in
     (substitutes? . #t)
     (build-hook? . #t)
     (print-build-trace? . #t)
+    (print-extended-build-trace? . #t)
     (verbosity . 0)))
 
 (define (show-help)
@@ -733,11 +739,12 @@ needed."
         ;; Set the build options before we do anything else.
         (set-build-options-from-command-line store opts)
 
-        (parameterize ((current-build-output-port
+        (parameterize ((current-terminal-columns (terminal-columns))
+                       (current-build-output-port
                         (if quiet?
                             (%make-void-port "w")
-                            (build-output-port #:verbose? #t
-                                               #:port (duplicate-port (current-error-port) "w")))))
+                            (build-event-output-port
+                             (build-status-updater print-build-event)))))
           (let* ((mode  (assoc-ref opts 'build-mode))
                  (drv   (options->derivations store opts))
                  (urls  (map (cut string-append <> "/log")
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 1c04800e42..9fc7edcd36 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -21,6 +21,7 @@
 (define-module (guix scripts environment)
   #:use-module (guix ui)
   #:use-module (guix store)
+  #:use-module (guix status)
   #:use-module (guix grafts)
   #:use-module (guix derivations)
   #:use-module (guix packages)
@@ -173,6 +174,8 @@ COMMAND or an interactive shell in that environment.\n"))
     (substitutes? . #t)
     (build-hook? . #t)
     (graft? . #t)
+    (print-build-trace? . #t)
+    (print-extended-build-trace? . #t)
     (verbosity . 0)))
 
 (define (tag-package-arg opts arg)
@@ -661,59 +664,60 @@ message if any test fails."
         (leave (G_ "'--user' cannot be used without '--container'~%")))
 
       (with-store store
-        (set-build-options-from-command-line store opts)
-
-        ;; Use the bootstrap Guile when requested.
-        (parameterize ((%graft? (assoc-ref opts 'graft?))
-                       (%guile-for-build
-                        (package-derivation
-                         store
-                         (if bootstrap?
-                             %bootstrap-guile
-                             (canonical-package guile-2.2)))))
-          (run-with-store store
-            ;; Containers need a Bourne shell at /bin/sh.
-            (mlet* %store-monad ((bash       (environment-bash container?
-                                                               bootstrap?
-                                                               system))
-                                 (prof-drv   (manifest->derivation
-                                              manifest system bootstrap?))
-                                 (profile -> (derivation->output-path prof-drv))
-                                 (gc-root -> (assoc-ref opts 'gc-root)))
-
-              ;; First build the inputs.  This is necessary even for
-              ;; --search-paths.  Additionally, we might need to build bash for
-              ;; a container.
-              (mbegin %store-monad
-                (build-environment (if (derivation? bash)
-                                       (list prof-drv bash)
-                                       (list prof-drv))
-                                   opts)
-                (mwhen gc-root
-                  (register-gc-root profile gc-root))
-
-                (cond
-                 ((assoc-ref opts 'dry-run?)
-                  (return #t))
-                 ((assoc-ref opts 'search-paths)
-                  (show-search-paths profile manifest #:pure? pure?)
-                  (return #t))
-                 (container?
-                  (let ((bash-binary
-                         (if bootstrap?
-                             bash
-                             (string-append (derivation->output-path bash)
-                                            "/bin/sh"))))
-                    (launch-environment/container #:command command
-                                                  #:bash bash-binary
-                                                  #:user user
-                                                  #:user-mappings mappings
-                                                  #:profile profile
-                                                  #:manifest manifest
-                                                  #:link-profile? link-prof?
-                                                  #:network? network?)))
-                 (else
-                  (return
-                   (exit/status
-                    (launch-environment/fork command profile manifest
-                                             #:pure? pure?)))))))))))))
+        (with-status-report print-build-event
+          (set-build-options-from-command-line store opts)
+
+          ;; Use the bootstrap Guile when requested.
+          (parameterize ((%graft? (assoc-ref opts 'graft?))
+                         (%guile-for-build
+                          (package-derivation
+                           store
+                           (if bootstrap?
+                               %bootstrap-guile
+                               (canonical-package guile-2.2)))))
+            (run-with-store store
+              ;; Containers need a Bourne shell at /bin/sh.
+              (mlet* %store-monad ((bash       (environment-bash container?
+                                                                 bootstrap?
+                                                                 system))
+                                   (prof-drv   (manifest->derivation
+                                                manifest system bootstrap?))
+                                   (profile -> (derivation->output-path prof-drv))
+                                   (gc-root -> (assoc-ref opts 'gc-root)))
+
+                ;; First build the inputs.  This is necessary even for
+                ;; --search-paths.  Additionally, we might need to build bash for
+                ;; a container.
+                (mbegin %store-monad
+                  (build-environment (if (derivation? bash)
+                                         (list prof-drv bash)
+                                         (list prof-drv))
+                                     opts)
+                  (mwhen gc-root
+                    (register-gc-root profile gc-root))
+
+                  (cond
+                   ((assoc-ref opts 'dry-run?)
+                    (return #t))
+                   ((assoc-ref opts 'search-paths)
+                    (show-search-paths profile manifest #:pure? pure?)
+                    (return #t))
+                   (container?
+                    (let ((bash-binary
+                           (if bootstrap?
+                               bash
+                               (string-append (derivation->output-path bash)
+                                              "/bin/sh"))))
+                      (launch-environment/container #:command command
+                                                    #:bash bash-binary
+                                                    #:user user
+                                                    #:user-mappings mappings
+                                                    #:profile profile
+                                                    #:manifest manifest
+                                                    #:link-profile? link-prof?
+                                                    #:network? network?)))
+                   (else
+                    (return
+                     (exit/status
+                      (launch-environment/fork command profile manifest
+                                               #:pure? pure?))))))))))))))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 1916f3b9d7..163f5b1dc1 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -25,6 +25,7 @@
   #:use-module (guix gexp)
   #:use-module (guix utils)
   #:use-module (guix store)
+  #:use-module (guix status)
   #:use-module (guix grafts)
   #:use-module (guix monads)
   #:use-module (guix modules)
@@ -538,6 +539,8 @@ please email '~a'~%")
     (substitutes? . #t)
     (build-hook? . #t)
     (graft? . #t)
+    (print-build-trace? . #t)
+    (print-extended-build-trace? . #t)
     (verbosity . 0)
     (symlinks . ())
     (compressor . ,(first %compressors))))
@@ -684,72 +687,73 @@ Create a bundle of PACKAGE.\n"))
 
   (with-error-handling
     (with-store store
-      ;; Set the build options before we do anything else.
-      (set-build-options-from-command-line store opts)
-
-      (parameterize ((%graft? (assoc-ref opts 'graft?))
-                     (%guile-for-build (package-derivation
-                                        store
-                                        (if (assoc-ref opts 'bootstrap?)
-                                            %bootstrap-guile
-                                            (canonical-package guile-2.2))
-                                        (assoc-ref opts 'system)
-                                        #:graft? (assoc-ref opts 'graft?))))
-        (let* ((dry-run?    (assoc-ref opts 'dry-run?))
-               (relocatable? (assoc-ref opts 'relocatable?))
-               (manifest    (let ((manifest (manifest-from-args store opts)))
-                              ;; Note: We cannot honor '--bootstrap' here because
-                              ;; 'glibc-bootstrap' lacks 'libc.a'.
-                              (if relocatable?
-                                  (map-manifest-entries wrapped-package manifest)
-                                  manifest)))
-               (pack-format (assoc-ref opts 'format))
-               (name        (string-append (symbol->string pack-format)
-                                           "-pack"))
-               (target      (assoc-ref opts 'target))
-               (bootstrap?  (assoc-ref opts 'bootstrap?))
-               (compressor  (if bootstrap?
-                                bootstrap-xz
-                                (assoc-ref opts 'compressor)))
-               (archiver    (if (equal? pack-format 'squashfs)
-                                squashfs-tools-next
-                                (if bootstrap?
-                                    %bootstrap-coreutils&co
-                                    tar)))
-               (symlinks    (assoc-ref opts 'symlinks))
-               (build-image (match (assq-ref %formats pack-format)
-                              ((? procedure? proc) proc)
-                              (#f
-                               (leave (G_ "~a: unknown pack format~%")
-                                      pack-format))))
-               (localstatedir? (assoc-ref opts 'localstatedir?)))
-          (run-with-store store
-            (mlet* %store-monad ((profile (profile-derivation
-                                           manifest
-                                           #:relative-symlinks? relocatable?
-                                           #:hooks (if bootstrap?
-                                                       '()
-                                                       %default-profile-hooks)
-                                           #:locales? (not bootstrap?)
-                                           #:target target))
-                                 (drv (build-image name profile
-                                                   #:target
-                                                   target
-                                                   #:compressor
-                                                   compressor
-                                                   #:symlinks
-                                                   symlinks
-                                                   #:localstatedir?
-                                                   localstatedir?
-                                                   #:archiver
-                                                   archiver)))
-              (mbegin %store-monad
-                (show-what-to-build* (list drv)
-                                     #:use-substitutes?
-                                     (assoc-ref opts 'substitutes?)
-                                     #:dry-run? dry-run?)
-                (munless dry-run?
-                  (built-derivations (list drv))
-                  (return (format #t "~a~%"
-                                  (derivation->output-path drv))))))
-            #:system (assoc-ref opts 'system)))))))
+      (with-status-report print-build-event
+        ;; Set the build options before we do anything else.
+        (set-build-options-from-command-line store opts)
+
+        (parameterize ((%graft? (assoc-ref opts 'graft?))
+                       (%guile-for-build (package-derivation
+                                          store
+                                          (if (assoc-ref opts 'bootstrap?)
+                                              %bootstrap-guile
+                                              (canonical-package guile-2.2))
+                                          (assoc-ref opts 'system)
+                                          #:graft? (assoc-ref opts 'graft?))))
+          (let* ((dry-run?    (assoc-ref opts 'dry-run?))
+                 (relocatable? (assoc-ref opts 'relocatable?))
+                 (manifest    (let ((manifest (manifest-from-args store opts)))
+                                ;; Note: We cannot honor '--bootstrap' here because
+                                ;; 'glibc-bootstrap' lacks 'libc.a'.
+                                (if relocatable?
+                                    (map-manifest-entries wrapped-package manifest)
+                                    manifest)))
+                 (pack-format (assoc-ref opts 'format))
+                 (name        (string-append (symbol->string pack-format)
+                                             "-pack"))
+                 (target      (assoc-ref opts 'target))
+                 (bootstrap?  (assoc-ref opts 'bootstrap?))
+                 (compressor  (if bootstrap?
+                                  bootstrap-xz
+                                  (assoc-ref opts 'compressor)))
+                 (archiver    (if (equal? pack-format 'squashfs)
+                                  squashfs-tools-next
+                                  (if bootstrap?
+                                      %bootstrap-coreutils&co
+                                      tar)))
+                 (symlinks    (assoc-ref opts 'symlinks))
+                 (build-image (match (assq-ref %formats pack-format)
+                                ((? procedure? proc) proc)
+                                (#f
+                                 (leave (G_ "~a: unknown pack format~%")
+                                        pack-format))))
+                 (localstatedir? (assoc-ref opts 'localstatedir?)))
+            (run-with-store store
+              (mlet* %store-monad ((profile (profile-derivation
+                                             manifest
+                                             #:relative-symlinks? relocatable?
+                                             #:hooks (if bootstrap?
+                                                         '()
+                                                         %default-profile-hooks)
+                                             #:locales? (not bootstrap?)
+                                             #:target target))
+                                   (drv (build-image name profile
+                                                     #:target
+                                                     target
+                                                     #:compressor
+                                                     compressor
+                                                     #:symlinks
+                                                     symlinks
+                                                     #:localstatedir?
+                                                     localstatedir?
+                                                     #:archiver
+                                                     archiver)))
+                (mbegin %store-monad
+                  (show-what-to-build* (list drv)
+                                       #:use-substitutes?
+                                       (assoc-ref opts 'substitutes?)
+                                       #:dry-run? dry-run?)
+                  (munless dry-run?
+                    (built-derivations (list drv))
+                    (return (format #t "~a~%"
+                                    (derivation->output-path drv))))))
+              #:system (assoc-ref opts 'system))))))))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index c3ed2ac935..93a77915fe 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -24,6 +24,7 @@
 
 (define-module (guix scripts package)
   #:use-module (guix ui)
+  #:use-module (guix status)
   #:use-module (guix store)
   #:use-module (guix grafts)
   #:use-module (guix derivations)
@@ -330,7 +331,8 @@ ENTRIES, a list of manifest entries, in the context of PROFILE."
     (graft? . #t)
     (substitutes? . #t)
     (build-hook? . #t)
-    (print-build-trace? . #t)))
+    (print-build-trace? . #t)
+    (print-extended-build-trace? . #t)))
 
 (define (show-help)
   (display (G_ "Usage: guix package [OPTION]...
@@ -941,15 +943,12 @@ processed, #f otherwise."
     (or (process-query opts)
         (parameterize ((%store  (open-connection))
                        (%graft? (assoc-ref opts 'graft?)))
-          (set-build-options-from-command-line (%store) opts)
-
-          (parameterize ((%guile-for-build
-                          (package-derivation
-                           (%store)
-                           (if (assoc-ref opts 'bootstrap?)
-                               %bootstrap-guile
-                               (canonical-package guile-2.2))))
-                         (current-build-output-port
-                          (build-output-port #:verbose? verbose?
-                                             #:port (duplicate-port (current-error-port) "w"))))
-            (process-actions (%store) opts))))))
+          (with-status-report print-build-event/quiet
+            (set-build-options-from-command-line (%store) opts)
+            (parameterize ((%guile-for-build
+                            (package-derivation
+                             (%store)
+                             (if (assoc-ref opts 'bootstrap?)
+                                 %bootstrap-guile
+                                 (canonical-package guile-2.2)))))
+              (process-actions (%store) opts)))))))
diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm
index 18e2fc92f2..9f6ecc00d2 100644
--- a/guix/scripts/perform-download.scm
+++ b/guix/scripts/perform-download.scm
@@ -48,6 +48,7 @@ OUTPUT.
 Note: Unless OUTPUT is #f, we don't read the value of 'out' in DRV since the
 actual output is different from that when we're doing a 'bmCheck' or
 'bmRepair' build."
+  ;; TODO: Use 'trace-progress-proc' when possible.
   (derivation-let drv ((url "url")
                        (output* "out")
                        (executable "executable")
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 39aebb18e2..803f7cf142 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -20,6 +20,7 @@
 (define-module (guix scripts pull)
   #:use-module (guix ui)
   #:use-module (guix utils)
+  #:use-module (guix status)
   #:use-module (guix scripts)
   #:use-module (guix store)
   #:use-module (guix config)
@@ -61,6 +62,8 @@
   `((system . ,(%current-system))
     (substitutes? . #t)
     (build-hook? . #t)
+    (print-build-trace? . #t)
+    (print-extended-build-trace? . #t)
     (graft? . #t)
     (verbosity . 0)))
 
@@ -447,36 +450,37 @@ Use '~/.config/guix/channels.scm' instead."))
               #t)                                 ;XXX: not very useful
              (else
               (with-store store
-                (parameterize ((%graft? (assoc-ref opts 'graft?))
-                               (%repository-cache-directory cache))
-                  (set-build-options-from-command-line store opts)
-                  (honor-x509-certificates store)
-
-                  (let ((instances (latest-channel-instances store channels)))
-                    (format (current-error-port)
-                            (N_ "Building from this channel:~%"
-                                "Building from these channels:~%"
-                                (length instances)))
-                    (for-each (lambda (instance)
-                                (let ((channel
-                                       (channel-instance-channel instance)))
-                                  (format (current-error-port)
-                                          "  ~10a~a\t~a~%"
-                                          (channel-name channel)
-                                          (channel-url channel)
-                                          (string-take
-                                           (channel-instance-commit instance)
-                                           7))))
-                              instances)
-                    (parameterize ((%guile-for-build
-                                    (package-derivation
-                                     store
-                                     (if (assoc-ref opts 'bootstrap?)
-                                         %bootstrap-guile
-                                         (canonical-package guile-2.2)))))
-                      (run-with-store store
-                        (build-and-install instances profile
-                                           #:verbose?
-                                           (assoc-ref opts 'verbose?)))))))))))))
+                (with-status-report print-build-event
+                  (parameterize ((%graft? (assoc-ref opts 'graft?))
+                                 (%repository-cache-directory cache))
+                    (set-build-options-from-command-line store opts)
+                    (honor-x509-certificates store)
+
+                    (let ((instances (latest-channel-instances store channels)))
+                      (format (current-error-port)
+                              (N_ "Building from this channel:~%"
+                                  "Building from these channels:~%"
+                                  (length instances)))
+                      (for-each (lambda (instance)
+                                  (let ((channel
+                                         (channel-instance-channel instance)))
+                                    (format (current-error-port)
+                                            "  ~10a~a\t~a~%"
+                                            (channel-name channel)
+                                            (channel-url channel)
+                                            (string-take
+                                             (channel-instance-commit instance)
+                                             7))))
+                                instances)
+                      (parameterize ((%guile-for-build
+                                      (package-derivation
+                                       store
+                                       (if (assoc-ref opts 'bootstrap?)
+                                           %bootstrap-guile
+                                           (canonical-package guile-2.2)))))
+                        (run-with-store store
+                          (build-and-install instances profile
+                                             #:verbose?
+                                             (assoc-ref opts 'verbose?))))))))))))))
 
 ;;; pull.scm ends here
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 50c6a22064..eb82224016 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -837,7 +837,16 @@ REPORTER, which should be a <progress-reporter> object."
        (make-custom-binary-input-port "progress-port-proc"
                                       read! #f #f
                                       (lambda ()
-                                        (stop)
+                                        ;; XXX: Kludge!  When used through
+                                        ;; 'decompressed-port', this port ends
+                                        ;; up being closed twice: once in a
+                                        ;; child process early on, and at the
+                                        ;; end in the parent process.  Ignore
+                                        ;; the early close so we don't output
+                                        ;; a spurious "download-succeeded"
+                                        ;; trace.
+                                        (unless (zero? total)
+                                          (stop))
                                         (close-port port)))))))
 
 (define-syntax with-networking
@@ -930,7 +939,7 @@ authorized substitutes."
      (error "unknown `--query' command" wtf))))
 
 (define* (process-substitution store-item destination
-                               #:key cache-urls acl)
+                               #:key cache-urls acl print-build-trace?)
   "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to
 DESTINATION as a nar file.  Verify the substitute against ACL."
   (let* ((narinfo (lookup-narinfo cache-urls store-item
@@ -943,8 +952,10 @@ DESTINATION as a nar file.  Verify the substitute against ACL."
     ;; Tell the daemon what the expected hash of the Nar itself is.
     (format #t "~a~%" (narinfo-hash narinfo))
 
-    (format (current-error-port)
-            (G_ "Downloading ~a...~%") (uri->string uri))
+    (unless print-build-trace?
+      (format (current-error-port)
+              (G_ "Downloading ~a...~%") (uri->string uri)))
+
     (let*-values (((raw download-size)
                    ;; Note that Hydra currently generates Nars on the fly
                    ;; and doesn't specify a Content-Length, so
@@ -955,10 +966,15 @@ DESTINATION as a nar file.  Verify the substitute against ACL."
                           (dl-size  (or download-size
                                         (and (equal? comp "none")
                                              (narinfo-size narinfo))))
-                          (reporter (progress-reporter/file
-                                     (uri->string uri) dl-size
-                                     (current-error-port)
-                                     #:abbreviation nar-uri-abbreviation)))
+                          (reporter (if print-build-trace?
+                                        (progress-reporter/trace
+                                         destination
+                                         (uri->string uri) dl-size
+                                         (current-error-port))
+                                        (progress-reporter/file
+                                         (uri->string uri) dl-size
+                                         (current-error-port)
+                                         #:abbreviation nar-uri-abbreviation))))
                      (progress-report-port reporter raw)))
                   ((input pids)
                    ;; NOTE: This 'progress' port of current process will be
@@ -1058,6 +1074,13 @@ default value."
 
 (define (guix-substitute . args)
   "Implement the build daemon's substituter protocol."
+  (define print-build-trace?
+    (match (or (find-daemon-option "untrusted-print-extended-build-trace")
+               (find-daemon-option "print-extended-build-trace"))
+      (#f #f)
+      ((= string->number number) (> number 0))
+      (_ #f)))
+
   (mkdir-p %narinfo-cache-directory)
   (maybe-remove-expired-cache-entries %narinfo-cache-directory
                                       cached-narinfo-files
@@ -1111,7 +1134,8 @@ default value."
         (parameterize ((current-terminal-columns (client-terminal-columns)))
           (process-substitution store-path destination
                                 #:cache-urls (substitute-urls)
-                                #:acl (current-acl))))
+                                #:acl (current-acl)
+                                #:print-build-trace? print-build-trace?)))
        ((or ("-V") ("--version"))
         (show-version-and-exit "guix substitute"))
        (("--help")
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 1e7620f147..f9d6b9e5b6 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -23,6 +23,7 @@
 (define-module (guix scripts system)
   #:use-module (guix config)
   #:use-module (guix ui)
+  #:use-module (guix status)
   #:use-module (guix store)
   #:autoload   (guix store database) (register-path)
   #:use-module (guix grafts)
@@ -1079,6 +1080,8 @@ Some ACTIONS support additional ARGS.\n"))
   `((system . ,(%current-system))
     (substitutes? . #t)
     (build-hook? . #t)
+    (print-build-trace? . #t)
+    (print-extended-build-trace? . #t)
     (graft? . #t)
     (verbosity . 0)
     (file-system-type . "ext4")
@@ -1253,9 +1256,11 @@ argument list and OPTS is the option alist."
                                          parse-sub-command))
            (args     (option-arguments opts))
            (command  (assoc-ref opts 'action)))
-      (parameterize ((%graft? (assoc-ref opts 'graft?))
-                     (current-terminal-columns (terminal-columns)))
-        (process-command command args opts)))))
+      (parameterize ((%graft? (assoc-ref opts 'graft?)))
+        (with-status-report (if (memq command '(init reconfigure))
+                                print-build-event/quiet
+                                print-build-event)
+          (process-command command args opts))))))
 
 ;;; Local Variables:
 ;;; eval: (put 'call-with-service-upgrade-info 'scheme-indent-function 1)
diff --git a/guix/status.scm b/guix/status.scm
new file mode 100644
index 0000000000..94d4748af5
--- /dev/null
+++ b/guix/status.scm
@@ -0,0 +1,493 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix status)
+  #:use-module (guix records)
+  #:use-module (guix i18n)
+  #:use-module ((guix ui) #:select (colorize-string))
+  #:use-module (guix progress)
+  #:autoload   (guix build syscalls) (terminal-columns)
+  #:use-module ((guix build download)
+                #:select (nar-uri-abbreviation))
+  #:use-module ((guix store)
+                #:select (current-build-output-port
+                          current-store-protocol-version
+                          log-file))
+  #:use-module (guix derivations)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (rnrs bytevectors)
+  #:use-module ((system foreign)
+                #:select (bytevector->pointer pointer->bytevector))
+  #:export (build-event-output-port
+            compute-status
+
+            build-status
+            build-status?
+            build-status-building
+            build-status-downloading
+            build-status-builds-completed
+            build-status-downloads-completed
+
+            download?
+            download
+            download-item
+            download-uri
+            download-size
+            download-start
+            download-end
+            download-transferred
+
+            build-status-updater
+            print-build-event
+            print-build-event/quiet
+            print-build-status
+
+            with-status-report))
+
+;;; Commentary:
+;;;
+;;; This module provides facilities to track the status of ongoing builds and
+;;; downloads in a given session, as well as tools to report about the current
+;;; status to user interfaces.  It does so by analyzing the output of
+;;; 'current-build-output-port'.  The build status is maintained in a
+;;; <build-status> record.
+;;;
+;;; Code:
+
+
+;;;
+;;; Build status tracking.
+;;;
+
+;; Builds and substitutions performed by the daemon.
+(define-record-type* <build-status> build-status make-build-status
+  build-status?
+  (building     build-status-building             ;list of drv
+                (default '()))
+  (downloading  build-status-downloading          ;list of <download>
+                (default '()))
+  (builds-completed build-status-builds-completed ;list of drv
+                    (default '()))
+  (downloads-completed build-status-downloads-completed ;list of store items
+                       (default '())))
+
+;; On-going or completed downloads.  Downloads can be stem from substitutes
+;; and from "builtin:download" fixed-output derivations.
+(define-record-type <download>
+  (%download item uri size start end transferred)
+  download?
+  (item         download-item)            ;store item
+  (uri          download-uri)             ;string | #f
+  (size         download-size)            ;integer | #f
+  (start        download-start)           ;<time>
+  (end          download-end)             ;#f | <time>
+  (transferred  download-transferred))    ;integer
+
+(define* (download item uri
+                   #:key size
+                   (start (current-time time-monotonic)) end
+                   (transferred 0))
+  "Return a new download."
+  (%download item uri size start end transferred))
+
+(define (matching-download item)
+  "Return a predicate that matches downloads of ITEM."
+  (lambda (download)
+    (string=? item (download-item download))))
+
+(define* (compute-status event status
+                         #:key (current-time current-time))
+  "Given EVENT, a tuple like (build-started \"/gnu/store/...-foo.drv\" ...),
+compute a new status based on STATUS."
+  (match event
+    (('build-started drv _ ...)
+     (build-status
+      (inherit status)
+      (building (cons drv (build-status-building status)))))
+    (((or 'build-succeeded 'build-failed) drv _ ...)
+     (build-status
+      (inherit status)
+      (building (delete drv (build-status-building status)))
+      (builds-completed (cons drv (build-status-builds-completed status)))))
+
+    ;; Note: Ignore 'substituter-started' and 'substituter-succeeded' because
+    ;; they're not as informative as 'download-started' and
+    ;; 'download-succeeded'.
+
+    (('download-started item uri (= string->number size))
+     ;; This is presumably a fixed-output derivation so move it from
+     ;; 'building' to 'downloading'.  XXX: This doesn't work in 'check' mode
+     ;; because ITEM is different from DRV's output.
+     (build-status
+      (inherit status)
+      (building (remove (lambda (drv)
+                          (equal? (false-if-exception
+                                   (derivation->output-path
+                                    (read-derivation-from-file drv)))
+                                  item))
+                        (build-status-building status)))
+      (downloading (cons (download item uri #:size size
+                                   #:start (current-time time-monotonic))
+                         (build-status-downloading status)))))
+    (('download-succeeded item uri (= string->number size))
+     (let ((current (find (matching-download item)
+                          (build-status-downloading status))))
+       (build-status
+        (inherit status)
+        (downloading (delq current (build-status-downloading status)))
+        (downloads-completed
+         (cons (download item uri
+                         #:size size
+                         #:start (download-start current)
+                         #:transferred size
+                         #:end (current-time time-monotonic))
+               (build-status-downloads-completed status))))))
+    (('substituter-succeeded item _ ...)
+     (match (find (matching-download item)
+                  (build-status-downloading status))
+       (#f
+        ;; Presumably we already got a 'download-succeeded' event for ITEM,
+        ;; everything is fine.
+        status)
+       (current
+        ;; Maybe the build process didn't emit a 'download-succeeded' event
+        ;; for ITEM, so remove CURRENT from the queue now.
+        (build-status
+         (inherit status)
+         (downloading (delq current (build-status-downloading status)))
+         (downloads-completed
+          (cons (download item (download-uri current)
+                          #:size (download-size current)
+                          #:start (download-start current)
+                          #:transferred (download-size current)
+                          #:end (current-time time-monotonic))
+                (build-status-downloads-completed status)))))))
+    (('download-progress item uri
+                         (= string->number size)
+                         (= string->number transferred))
+     (let ((downloads (remove (matching-download item)
+                              (build-status-downloading status)))
+           (current   (find (matching-download item)
+                            (build-status-downloading status))))
+       (build-status
+        (inherit status)
+        (downloading (cons (download item uri
+                                     #:size size
+                                     #:start
+                                     (or (and current
+                                              (download-start current))
+                                         (current-time time-monotonic))
+                                     #:transferred transferred)
+                           downloads)))))
+    (_
+     status)))
+
+(define (simultaneous-jobs status)
+  "Return the number of on-going builds and downloads for STATUS."
+  (+ (length (build-status-building status))
+     (length (build-status-downloading status))))
+
+
+;;;
+;;; Rendering.
+;;;
+
+(define (extended-build-trace-supported?)
+  "Return true if the currently used store is known to support \"extended
+build traces\" such as \"@ download-progress\" traces."
+  ;; Support for extended build traces was added in protocol version #x162.
+  (and (current-store-protocol-version)
+       (>= (current-store-protocol-version) #x162)))
+
+(define spin!
+  (let ((steps (circular-list "\\" "|" "/" "-")))
+    (lambda (port)
+      "Display a spinner on PORT."
+      (match steps
+        ((first . rest)
+         (set! steps rest)
+         (display "\r\x1b[K" port)
+         (display first port)
+         (force-output port))))))
+
+(define (color-output? port)
+  "Return true if we should write colored output to PORT."
+  (and (not (getenv "INSIDE_EMACS"))
+       (not (getenv "NO_COLOR"))
+       (isatty? port)))
+
+(define-syntax color-rules
+  (syntax-rules ()
+    "Return a procedure that colorizes the string it is passed according to
+the given rules.  Each rule has the form:
+
+  (REGEXP COLOR1 COLOR2 ...)
+
+where COLOR1 specifies how to colorize the first submatch of REGEXP, and so
+on."
+    ((_ (regexp colors ...) rest ...)
+     (let ((next (color-rules rest ...))
+           (rx   (make-regexp regexp)))
+       (lambda (str)
+         (if (string-index str #\nul)
+             str
+             (match (regexp-exec rx str)
+               (#f (next str))
+               (m  (let loop ((n 1)
+                              (c '(colors ...))
+                              (result '()))
+                     (match c
+                       (()
+                        (string-concatenate-reverse result))
+                       ((first . tail)
+                        (loop (+ n 1) tail
+                              (cons (colorize-string (match:substring m n)
+                                                     first)
+                                    result)))))))))))
+    ((_)
+     (lambda (str)
+       str))))
+
+(define colorize-log-line
+  ;; Take a string and return a possibly colorized string according to the
+  ;; rules below.
+  (color-rules
+   ("^(phase)(.*)(succeeded after)(.*)(seconds)(.*)"
+    GREEN    BOLD GREEN          RESET  GREEN  BLUE)
+   ("^(phase)(.*)(failed after)(.*)(seconds)(.*)"
+    RED BLUE RED BLUE RED BLUE)
+   ("^(.*)(error|fail|failed|FAIL|FAILED)([[:blank:]]*)(:)(.*)"
+    RESET  RED                           BOLD         BOLD BOLD)
+   ("^(.*)(warning)([[:blank:]]*)(:)(.*)"
+    RESET  ORANGE   BOLD        BOLD BOLD)))
+
+(define* (print-build-event event old-status status
+                            #:optional (port (current-error-port))
+                            #:key
+                            (colorize? (color-output? port))
+                            (print-log? #t))
+  "Print information about EVENT and STATUS to PORT.  When COLORIZE? is true,
+produce colorful output.  When PRINT-LOG? is true, display the build log in
+addition to build events."
+  (define info
+    (if colorize?
+        (cut colorize-string <> 'BOLD)
+        identity))
+
+  (define success
+    (if colorize?
+        (cut colorize-string <> 'GREEN 'BOLD)
+        identity))
+
+  (define failure
+    (if colorize?
+        (cut colorize-string <> 'RED 'BOLD)
+        identity))
+
+  (define print-log-line
+    (if print-log?
+        (if colorize?
+            (lambda (line)
+              (display (colorize-log-line line) port))
+            (cut display <> port))
+        (lambda (line)
+          (spin! port))))
+
+  (display "\r" port)                             ;erase the spinner
+  (match event
+    (('build-started drv . _)
+     (format port (info (G_ "building ~a...")) drv)
+     (newline port))
+    (('build-succeeded drv . _)
+     (format port (success (G_ "successfully built ~a")) drv)
+     (newline port)
+     (match (build-status-building status)
+       (() #t)
+       (ongoing                                   ;when max-jobs > 1
+        (format port
+                (N_ "The following build is still in progress:~%~{  ~a~%~}~%"
+                    "The following builds are still in progress:~%~{  ~a~%~}~%"
+                    (length ongoing))
+                ongoing))))
+    (('build-failed drv . _)
+     (format port (failure (G_ "build of ~a failed")) drv)
+     (newline port)
+     (format port (info (G_ "View build log at '~a'.~%"))
+             (log-file #f drv)))
+    (('substituter-started item _ ...)
+     (when (or print-log? (not (extended-build-trace-supported?)))
+       (format port (info (G_ "substituting ~a...")) item)
+       (newline port)))
+    (('download-started item uri _ ...)
+     (format port (info (G_ "downloading from ~a...")) uri)
+     (newline port))
+    (('download-progress item uri
+                         (= string->number size)
+                         (= string->number transferred))
+     ;; Print a progress bar, but only if there's only one on-going
+     ;; job--otherwise the output would be intermingled.
+     (when (= 1 (simultaneous-jobs status))
+       (match (find (matching-download item)
+                    (build-status-downloading status))
+         (#f #f)                                  ;shouldn't happen!
+         (download
+          ;; XXX: It would be nice to memoize the abbreviation.
+          (let ((uri (if (string-contains uri "/nar/")
+                         (nar-uri-abbreviation uri)
+                         (basename uri))))
+            (display-download-progress uri size
+                                       #:start-time
+                                       (download-start download)
+                                       #:transferred transferred))))))
+    (('substituter-succeeded item _ ...)
+     ;; If there are no jobs running, we already reported download completion
+     ;; so there's nothing left to do.
+     (unless (and (zero? (simultaneous-jobs status))
+                  (extended-build-trace-supported?))
+       (format port (success (G_ "substitution of ~a complete")) item)
+       (newline port)))
+    (('substituter-failed item _ ...)
+     (format port (failure (G_ "substitution of ~a failed")) item)
+     (newline port))
+    (('hash-mismatch item algo expected actual _ ...)
+     ;; TRANSLATORS: The final string looks like "sha256 hash mismatch for
+     ;; /gnu/store/…-sth:", where "sha256" is the hash algorithm.
+     (format port (failure (G_ "~a hash mismatch for ~a:")) algo item)
+     (newline port)
+     (format port (info (G_ "\
+  expected hash: ~a
+  actual hash:   ~a~%"))
+             expected actual))
+    (('build-log line)
+     ;; The daemon prefixes early messages coming with 'guix substitute' with
+     ;; "substitute:".  These are useful ("updating substitutes from URL"), so
+     ;; let them through.
+     (if (string-prefix? "substitute: " line)
+         (begin
+           (format port line)
+           (force-output port))
+         (print-log-line line)))
+    (_
+     event)))
+
+(define* (print-build-event/quiet event old-status status
+                                  #:optional
+                                  (port (current-error-port))
+                                  #:key
+                                  (colorize? (color-output? port)))
+  (print-build-event event old-status status port
+                     #:colorize? colorize?
+                     #:print-log? #f))
+
+(define* (build-status-updater #:optional (on-change (const #t)))
+  "Return a procedure that can be passed to 'build-event-output-port'.  That
+procedure computes the new build status upon each event and calls ON-CHANGE:
+
+  (ON-CHANGE event status new-status)
+
+ON-CHANGE can display the build status, build events, etc."
+  (lambda (event status)
+    (let ((new (compute-status event status)))
+      (on-change event status new)
+      new)))
+
+
+;;;
+;;; Build port.
+;;;
+
+(define %newline
+  (char-set #\return #\newline))
+
+(define* (build-event-output-port proc #:optional (seed (build-status)))
+  "Return an output port for use as 'current-build-output-port' that calls
+PROC with its current state value, initialized with SEED, on every build
+event.  Build events passed to PROC are tuples corresponding to the \"build
+traces\" produced by the daemon:
+
+  (build-started \"/gnu/store/...-foo.drv\" ...)
+  (substituter-started \"/gnu/store/...-foo\" ...)
+
+and so on.
+
+The second return value is a thunk to retrieve the current state."
+  (define %fragments
+    ;; Line fragments received so far.
+    '())
+
+  (define %state
+    ;; Current state for PROC.
+    seed)
+
+  (define (process-line line)
+    (if (string-prefix? "@ " line)
+        (match (string-tokenize (string-drop line 2))
+          (((= string->symbol event-name) args ...)
+           (set! %state
+             (proc (cons event-name args)
+                   %state))))
+        (set! %state (proc (list 'build-log line)
+                           %state))))
+
+  (define (bytevector-range bv offset count)
+    (let ((ptr (bytevector->pointer bv offset)))
+      (pointer->bytevector ptr count)))
+
+  (define (write! bv offset count)
+    (let loop ((str (utf8->string (bytevector-range bv offset count))))
+      (match (string-index str %newline)
+        ((? integer? cr)
+         (let ((tail (string-take str (+ 1 cr))))
+           (process-line (string-concatenate-reverse
+                          (cons tail %fragments)))
+           (set! %fragments '())
+           (loop (string-drop str (+ 1 cr)))))
+        (#f
+         (unless (string-null? str)
+           (set! %fragments (cons str %fragments)))
+         count))))
+
+  (define port
+    (make-custom-binary-output-port "filtering-input-port"
+                                    write!
+                                    #f #f
+                                    #f))
+
+  ;; The build port actually receives Unicode strings.
+  (set-port-encoding! port "UTF-8")
+  (setvbuf port (cond-expand (guile-2.2 'line) (else _IOLBF)))
+
+  (values port (lambda () %state)))
+
+(define (call-with-status-report on-event thunk)
+  (parameterize ((current-terminal-columns (terminal-columns))
+                 (current-build-output-port
+                  (build-event-output-port (build-status-updater on-event))))
+    (thunk)))
+
+(define-syntax-rule (with-status-report on-event exp ...)
+  "Set up build status reporting to the user using the ON-EVENT procedure;
+evaluate EXP... in that context."
+  (call-with-status-report on-event (lambda () exp ...)))
diff --git a/guix/store.scm b/guix/store.scm
index f88cdefe87..7785a53aa1 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -50,9 +50,11 @@
             %default-substitute-urls
 
             nix-server?
+            nix-server-version
             nix-server-major-version
             nix-server-minor-version
             nix-server-socket
+            current-store-protocol-version        ;for internal use
 
             &nix-error nix-error?
             &nix-connection-error nix-connection-error?
@@ -152,7 +154,7 @@
             direct-store-path
             log-file))
 
-(define %protocol-version #x161)
+(define %protocol-version #x162)
 
 (define %worker-magic-1 #x6e697863)               ; "nixc"
 (define %worker-magic-2 #x6478696f)               ; "dxio"
@@ -161,6 +163,8 @@
   (logand magic #xff00))
 (define (protocol-minor magic)
   (logand magic #x00ff))
+(define (protocol-version major minor)
+  (logior major minor))
 
 (define-syntax define-enumerate-type
   (syntax-rules ()
@@ -540,6 +544,11 @@ connection.  Use with care."
                       (make-hash-table 100)
                       (make-hash-table 100))))
 
+(define (nix-server-version store)
+  "Return the protocol version of STORE as an integer."
+  (protocol-version (nix-server-major-version store)
+                    (nix-server-minor-version store)))
+
 (define (write-buffered-output server)
   "Flush SERVER's output port."
   (force-output (nix-server-output-port server))
@@ -556,10 +565,20 @@ automatically close the store when the dynamic extent of EXP is left."
     (dynamic-wind
       (const #f)
       (lambda ()
-        exp ...)
+        (parameterize ((current-store-protocol-version
+                        (nix-server-version store)))
+         exp) ...)
       (lambda ()
         (false-if-exception (close-connection store))))))
 
+(define current-store-protocol-version
+  ;; Protocol version of the store currently used.  XXX: This is a hack to
+  ;; communicate the protocol version to the build output port.  It's a hack
+  ;; because it could be inaccurrate, for instance if there's code that
+  ;; manipulates several store connections at once; it works well for the
+  ;; purposes of (guix status) though.
+  (make-parameter #f))
+
 (define current-build-output-port
   ;; The port where build output is sent.
   (make-parameter (current-error-port)))
@@ -682,6 +701,13 @@ encoding conversion errors."
                             (build-verbosity 0)
                             (log-type 0)
                             (print-build-trace #t)
+
+                            ;; When true, provide machine-readable "build
+                            ;; traces" for use by (guix status).  Old clients
+                            ;; are unable to make sense, which is why it's
+                            ;; disabled by default.
+                            print-extended-build-trace?
+
                             build-cores
                             (use-substitutes? #t)
 
@@ -725,7 +751,12 @@ encoding conversion errors."
     (when (>= (nix-server-minor-version server) 10)
       (send (boolean use-substitutes?)))
     (when (>= (nix-server-minor-version server) 12)
-      (let ((pairs `(,@(if timeout
+      (let ((pairs `(;; This option is honored by 'guix substitute' et al.
+                     ,@(if print-build-trace
+                           `(("print-extended-build-trace"
+                              . ,(if print-extended-build-trace? "1" "0")))
+                           '())
+                     ,@(if timeout
                            `(("build-timeout" . ,(number->string timeout)))
                            '())
                      ,@(if max-silent-time
@@ -1064,13 +1095,15 @@ an arbitrary directory layout in the store without creating a derivation."
 outputs, and return when the worker is done building them.  Elements of THINGS
 that are not derivations can only be substituted and not built locally.
 Return #t on success."
-      (if (>= (nix-server-minor-version store) 15)
-          (build store things mode)
-          (if (= mode (build-mode normal))
-              (build/old store things)
-              (raise (condition (&nix-protocol-error
-                                 (message "unsupported build mode")
-                                 (status  1)))))))))
+      (parameterize ((current-store-protocol-version
+                      (nix-server-version store)))
+        (if (>= (nix-server-minor-version store) 15)
+            (build store things mode)
+            (if (= mode (build-mode normal))
+                (build/old store things)
+                (raise (condition (&nix-protocol-error
+                                   (message "unsupported build mode")
+                                   (status  1))))))))))
 
 (define-operation (add-temp-root (store-path path))
   "Make PATH a temporary root for the duration of the current session.
diff --git a/guix/ui.scm b/guix/ui.scm
index c55ae7e2f8..96f403acf5 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -119,7 +119,7 @@
             warning
             info
             guix-main
-            build-output-port))
+            colorize-string))
 
 ;;; Commentary:
 ;;;
@@ -1676,124 +1676,4 @@ be reset such that subsequent output will not have any colors in effect."
    str
    (color 'RESET)))
 
-(define* (build-output-port #:key
-                            (colorize? #t)
-                            verbose?
-                            (port (current-error-port)))
-  "Return a soft port that processes build output.  By default it colorizes
-phase announcements and replaces any other output with a spinner."
-  (define spun? #f)
-  (define spin!
-    (let ((steps (circular-list "\\" "|" "/" "-")))
-      (lambda ()
-        (match steps
-          ((first . rest)
-           (set! steps rest)
-           (set! spun? #t) ; remember to erase spinner
-           first)))))
-
-  (define use-color?
-    (and colorize?
-         (not (or (getenv "NO_COLOR")
-                  (getenv "INSIDE_EMACS")
-                  (not (isatty? port))))))
-
-  (define handle-string
-    (let* ((proc (if use-color?
-                     colorize-string
-                     (lambda (s . _) s)))
-           (rules `(("^(@ build-started) (.*) (.*)"
-                     #:transform
-                     ,(lambda (m)
-                        (string-append
-                         (proc "Building " 'BLUE 'BOLD)
-                         (match:substring m 2) "\n")))
-                    ,(if verbose?
-                         ;; Err on the side of caution: show everything, even
-                         ;; if it might be redundant.
-                         `("^(@ build-failed)(.+)"
-                           #:transform
-                           ,(lambda (m)
-                              (string-append
-                               (proc "Build failed: " 'RED 'BOLD)
-                               (match:substring m 2))))
-                         ;; Show only that the build failed.
-                         `("^(@ build-failed)(.+) -.*"
-                           #:transform
-                           ,(lambda (m)
-                              (string-append
-                               (proc "Build failed: " 'RED 'BOLD)
-                               (match:substring m 2)
-                               "\n"))))
-                    ;; NOTE: this line contains "\n" characters.
-                    ("^(sha256 hash mismatch for output path)(.*)"
-                     RED BLACK)
-                    ("^(@ build-succeeded) (.*) (.*)"
-                     #:transform
-                     ,(lambda (m)
-                        (string-append
-                         (proc "Built " 'GREEN 'BOLD)
-                         (match:substring m 2) "\n")))
-                    ("^(@ substituter-started) (.*) (.*)"
-                     #:transform
-                     ,(lambda (m)
-                        (string-append
-                         (proc "Substituting " 'BLUE 'BOLD)
-                         (match:substring m 2) "\n")))
-                    ("^(@ substituter-failed) (.*) (.*) (.*)"
-                     #:transform
-                     ,(lambda (m)
-                        (string-append
-                         (proc "Substituter failed: " 'RED 'BOLD)
-                         (match:substring m 2) "\n"
-                         (match:substring m 3) ": "
-                         (match:substring m 4) "\n")))
-                    ("^(@ substituter-succeeded) (.*)"
-                     #:transform
-                     ,(lambda (m)
-                        (string-append
-                         (proc "Substituted " 'GREEN 'BOLD)
-                         (match:substring m 2) "\n")))
-                    ("^(starting phase )(.*)"
-                     BLUE GREEN)
-                    ("^(phase)(.*)(succeeded after)(.*)(seconds)(.*)"
-                     GREEN BLUE GREEN BLUE GREEN BLUE)
-                    ("^(phase)(.*)(failed after)(.*)(seconds)(.*)"
-                     RED BLUE RED BLUE RED BLUE))))
-      (lambda (str)
-        (let ((processed
-               (any (match-lambda
-                      ((pattern #:transform transform)
-                       (and=> (string-match pattern str)
-                              transform))
-                      ((pattern . colors)
-                       (and=> (string-match pattern str)
-                              (lambda (m)
-                                (let ((substrings
-                                       (map (cut match:substring m <>)
-                                            (iota (- (match:count m) 1) 1))))
-                                  (string-join (map proc substrings colors) ""))))))
-                    rules)))
-          (when spun?
-            (display (string #\backspace) port))
-          (if processed
-              (begin
-                (display processed port)
-                (set! spun? #f))
-              ;; Print unprocessed line, or replace with spinner
-              (display (if verbose? str (spin!)) port))))))
-  (make-soft-port
-   (vector
-    ;; procedure accepting one character for output
-    (cut write <> port)
-    ;; procedure accepting a string for output
-    handle-string
-    ;; thunk for flushing output
-    (lambda () (force-output port))
-    ;; thunk for getting one character
-    (const #t)
-    ;; thunk for closing port (not by garbage collection)
-    (lambda () (close port)))
-   "w"))
-
 ;;; ui.scm ends here
diff --git a/nix/libstore/build.cc b/nix/libstore/build.cc
index c7f32494d0..b2c319f00b 100644
--- a/nix/libstore/build.cc
+++ b/nix/libstore/build.cc
@@ -2466,13 +2466,13 @@ void DerivationGoal::registerOutputs()
 
             /* Check the hash. */
             Hash h2 = recursive ? hashPath(ht, actualPath).first : hashFile(ht, actualPath);
-            if (h != h2)
-                throw BuildError(
-                    format("%1% hash mismatch for output path `%2%'\n"
-			   "  expected: %3%\n"
-			   "  actual:   %4%")
-                    % i->second.hashAlgo % path
-		    % printHash16or32(h) % printHash16or32(h2));
+            if (h != h2) {
+		if (settings.printBuildTrace)
+		    printMsg(lvlError, format("@ hash-mismatch %1% %2% %3% %4%")
+			     % path % i->second.hashAlgo
+			     % printHash16or32(h) % printHash16or32(h2));
+                throw BuildError(format("hash mismatch for store item '%1%'") % path);
+	    }
         }
 
         /* Get rid of all weird permissions.  This also checks that
@@ -3157,11 +3157,14 @@ void SubstitutionGoal::finished()
                 throw Error(format("unknown hash algorithm in `%1%'") % expectedHashStr);
             Hash expectedHash = parseHash16or32(hashType, string(expectedHashStr, n + 1));
             Hash actualHash = hashType == htSHA256 ? hash.first : hashPath(hashType, destPath).first;
-            if (expectedHash != actualHash)
-                throw SubstError(format("hash mismatch in downloaded path `%1%'\n"
-					"  expected: %2%\n"
-					"  actual:   %3%")
-                    % storePath % printHash(expectedHash) % printHash(actualHash));
+            if (expectedHash != actualHash) {
+		if (settings.printBuildTrace)
+		    printMsg(lvlError, format("@ hash-mismatch %1% %2% %3% %4%")
+			     % storePath % "sha256"
+			     % printHash16or32(expectedHash)
+			     % printHash16or32(actualHash));
+                throw SubstError(format("hash mismatch for substituted item `%1%'") % storePath);
+	    }
         }
 
     } catch (SubstError & e) {
diff --git a/nix/libstore/worker-protocol.hh b/nix/libstore/worker-protocol.hh
index efe9eadf23..103d60a8c2 100644
--- a/nix/libstore/worker-protocol.hh
+++ b/nix/libstore/worker-protocol.hh
@@ -6,7 +6,7 @@ namespace nix {
 #define WORKER_MAGIC_1 0x6e697863
 #define WORKER_MAGIC_2 0x6478696f
 
-#define PROTOCOL_VERSION 0x161
+#define PROTOCOL_VERSION 0x162
 #define GET_PROTOCOL_MAJOR(x) ((x) & 0xff00)
 #define GET_PROTOCOL_MINOR(x) ((x) & 0x00ff)
 
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index 2762ea078a..df2cf12de2 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -37,6 +37,7 @@ guix/scripts/container.scm
 guix/scripts/container/exec.scm
 guix/upstream.scm
 guix/ui.scm
+guix/status.scm
 guix/http-client.scm
 guix/nar.scm
 guix/channels.scm
diff --git a/tests/status.scm b/tests/status.scm
new file mode 100644
index 0000000000..04dedb702c
--- /dev/null
+++ b/tests/status.scm
@@ -0,0 +1,115 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (test-status)
+  #:use-module (guix status)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-64))
+
+(test-begin "status")
+
+(test-equal "compute-status, no-op"
+  (build-status)
+  (let-values (((port get-status)
+                (build-event-output-port compute-status)))
+    (display "foo\nbar\n\baz\n" port)
+    (get-status)))
+
+(test-equal "compute-status, builds + substitutes"
+  (list (build-status
+         (building '("foo.drv"))
+         (downloading (list (download "bar" "http://example.org/bar"
+                                      #:size 500
+                                      #:start 'now))))
+        (build-status
+         (building '("foo.drv"))
+         (downloading (list (download "bar" "http://example.org/bar"
+                                      #:size 500
+                                      #:transferred 42
+                                      #:start 'now))))
+        (build-status
+         (builds-completed '("foo.drv"))
+         (downloads-completed (list (download "bar" "http://example.org/bar"
+                                              #:size 500
+                                              #:transferred 500
+                                              #:start 'now
+                                              #:end 'now)))))
+  (let-values (((port get-status)
+                (build-event-output-port (lambda (event status)
+                                           (compute-status event status
+                                                           #:current-time
+                                                           (const 'now))))))
+    (display "@ build-started foo.drv\n" port)
+    (display "@ substituter-started bar\n" port)
+    (display "@ download-started bar http://example.org/bar 500\n" port)
+    (display "various\nthings\nget\nwritten\n" port)
+    (let ((first (get-status)))
+      (display "@ download-progress bar http://example.org/bar 500 42\n"
+               port)
+      (let ((second (get-status)))
+        (display "@ download-progress bar http://example.org/bar 500 84\n"
+                 port)
+        (display "@ build-succeeded foo.drv\n" port)
+        (display "@ download-succeeded bar http://example.org/bar 500\n" port)
+        (display "Almost done!\n" port)
+        (display "@ substituter-succeeded bar\n" port)
+        (list first second (get-status))))))
+
+(test-equal "compute-status, missing events"
+  (list (build-status
+         (building '("foo.drv"))
+         (downloading (list (download "baz" "http://example.org/baz"
+                                      #:size 500
+                                      #:transferred 42
+                                      #:start 'now)
+                            (download "bar" "http://example.org/bar"
+                                      #:size 999
+                                      #:transferred 0
+                                      #:start 'now))))
+        (build-status
+         (builds-completed '("foo.drv"))
+         (downloads-completed (list (download "baz" "http://example.org/baz"
+                                              #:size 500
+                                              #:transferred 500
+                                              #:start 'now
+                                              #:end 'now)
+                                    (download "bar" "http://example.org/bar"
+                                              #:size 999
+                                              #:transferred 999
+                                              #:start 'now
+                                              #:end 'now)))))
+  ;; Below we omit 'substituter-started' events and the like.
+  (let-values (((port get-status)
+                (build-event-output-port (lambda (event status)
+                                           (compute-status event status
+                                                           #:current-time
+                                                           (const 'now))))))
+    (display "@ build-started foo.drv\n" port)
+    (display "@ download-started bar http://example.org/bar 999\n" port)
+    (display "various\nthings\nget\nwritten\n" port)
+    (display "@ download-progress baz http://example.org/baz 500 42\n"
+             port)
+    (let ((first (get-status)))
+      (display "@ build-succeeded foo.drv\n" port)
+      (display "@ download-succeeded bar http://example.org/bar 999\n" port)
+      (display "Almost done!\n" port)
+      (display "@ substituter-succeeded baz\n" port)
+      (list first (get-status)))))
+
+(test-end "status")
-- 
cgit v1.2.3