Merge branch 'master' into core-updates

17 files changed, 971 insertions, 395 deletions

diff --git a/guix/build-system/haskell.scm b/guix/build-system/haskell.scm
index 1cb734631c..1ec11c71d8 100644
--- a/guix/build-system/haskell.scm
+++ b/guix/build-system/haskell.scm
@@ -21,6 +21,7 @@
   #:use-module (guix utils)
   #:use-module (guix packages)
   #:use-module (guix derivations)
+  #:use-module (guix download)
   #:use-module (guix search-paths)
   #:use-module (guix build-system)
   #:use-module (guix build-system gnu)
@@ -48,14 +49,35 @@
   (let ((haskell (resolve-interface '(gnu packages haskell))))
     (module-ref haskell 'ghc)))
 
+(define (source-url->revision-url url revision)
+  "Convert URL (a Hackage source URL) to the URL for the Cabal file at
+version REVISION."
+  (let* ((last-slash (string-rindex url #\/))
+         (next-slash (string-rindex url #\/ 0 last-slash)))
+    (string-append (substring url 0 next-slash)
+                   (substring url last-slash (- (string-length url)
+                                                (string-length ".tar.gz")))
+                   "/revision/" revision ".cabal")))
+
 (define* (lower name
                 #:key source inputs native-inputs outputs system target
                 (haskell (default-haskell))
+                cabal-revision
                 #:allow-other-keys
                 #:rest arguments)
   "Return a bag for NAME."
   (define private-keywords
-    '(#:target #:haskell #:inputs #:native-inputs))
+    '(#:target #:haskell #:cabal-revision #:inputs #:native-inputs))
+
+  (define (cabal-revision->origin cabal-revision)
+    (match cabal-revision
+      ((revision hash)
+       (origin
+         (method url-fetch)
+         (uri (source-url->revision-url (origin-uri source) revision))
+         (sha256 (base32 hash))
+         (file-name (string-append name "-" revision ".cabal"))))
+      (#f #f)))
 
   (and (not target)                               ;XXX: no cross-compilation
        (bag
@@ -64,6 +86,9 @@
          (host-inputs `(,@(if source
                               `(("source" ,source))
                               '())
+                        ,@(match (cabal-revision->origin cabal-revision)
+                            (#f '())
+                            (revision `(("cabal-revision" ,revision))))
                         ,@inputs
 
                         ;; Keep the standard inputs of 'gnu-build-system'.
@@ -103,6 +128,11 @@ provides a 'Setup.hs' file as its build system."
                                    source)
                                   (source
                                    source))
+                      #:cabal-revision ,(match (assoc-ref inputs
+                                                          "cabal-revision")
+                                          (((? derivation? revision))
+                                           (derivation->output-path revision))
+                                          (revision revision))
                       #:configure-flags ,configure-flags
                       #:haddock-flags ,haddock-flags
                       #:system ,system
diff --git a/guix/build/download.scm b/guix/build/download.scm
index 315a3554ec..54163849a2 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -115,7 +115,7 @@ and 'guix publish', something like
         (string-drop path 33)
         path)))
 
-(define* (ftp-fetch uri file #:key timeout)
+(define* (ftp-fetch uri file #:key timeout print-build-trace?)
   "Fetch data from URI and write it to FILE.  Return FILE on success.  Bail
 out if the connection could not be established in less than TIMEOUT seconds."
   (let* ((conn (match (and=> (uri-userinfo uri)
@@ -136,12 +136,17 @@ out if the connection could not be established in less than TIMEOUT seconds."
       (lambda (out)
         (dump-port* in out
                     #:buffer-size %http-receive-buffer-size
-                    #:reporter (progress-reporter/file
-                                (uri-abbreviation uri) size))))
-
-    (ftp-close conn))
-    (newline)
-  file)
+                    #:reporter
+                    (if print-build-trace?
+                        (progress-reporter/trace
+                         file (uri->string uri) size)
+                        (progress-reporter/file
+                         (uri-abbreviation uri) size)))))
+
+    (ftp-close conn)
+    (unless print-build-trace?
+      (newline))
+    file))
 
 ;; Autoload GnuTLS so that this module can be used even when GnuTLS is
 ;; not available.  At compile time, this yields "possibly unbound
@@ -723,7 +728,8 @@ Return a list of URIs."
                     #:key
                     (timeout 10) (verify-certificate? #t)
                     (mirrors '()) (content-addressed-mirrors '())
-                    (hashes '()))
+                    (hashes '())
+                    print-build-trace?)
   "Fetch FILE from URL; URL may be either a single string, or a list of
 string denoting alternate URLs for FILE.  Return #f on failure, and FILE
 on success.
@@ -759,13 +765,18 @@ otherwise simply ignore them."
             (lambda (output)
               (dump-port* port output
                           #:buffer-size %http-receive-buffer-size
-                          #:reporter (progress-reporter/file
-                                      (uri-abbreviation uri) size))
+                          #:reporter (if print-build-trace?
+                                         (progress-reporter/trace
+                                          file (uri->string uri) size)
+                                         (progress-reporter/file
+                                          (uri-abbreviation uri) size)))
               (newline)))
           file)))
       ((ftp)
        (false-if-exception* (ftp-fetch uri file
-                                       #:timeout timeout)))
+                                       #:timeout timeout
+                                       #:print-build-trace?
+                                       print-build-trace?)))
       (else
        (format #t "skipping URI with unsupported scheme: ~s~%"
                uri)
diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm
index 5a72d22842..72714a29ad 100644
--- a/guix/build/haskell-build-system.scm
+++ b/guix/build/haskell-build-system.scm
@@ -28,6 +28,7 @@
   #:use-module (ice-9 regex)
   #:use-module (ice-9 match)
   #:use-module (ice-9 vlist)
+  #:use-module (ice-9 ftw)
   #:export (%standard-phases
             haskell-build))
 
@@ -266,8 +267,19 @@ given Haskell package."
     (run-setuphs "haddock" haddock-flags))
   #t)
 
+(define* (patch-cabal-file #:key cabal-revision #:allow-other-keys)
+  (when cabal-revision
+    ;; Cabal requires there to be a single file with the suffix ".cabal".
+    (match (scandir "." (cut string-suffix? ".cabal" <>))
+      ((original)
+       (format #t "replacing ~s with ~s~%" original cabal-revision)
+       (copy-file cabal-revision original))
+      (_ (error "Could not find a Cabal file to patch."))))
+  #t)
+
 (define %standard-phases
   (modify-phases gnu:%standard-phases
+    (add-after 'unpack 'patch-cabal-file patch-cabal-file)
     (delete 'bootstrap)
     (add-before 'configure 'setup-compiler setup-compiler)
     (add-before 'install 'haddock haddock)
diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm
index 6470cfec97..97bc6197a3 100644
--- a/guix/build/lisp-utils.scm
+++ b/guix/build/lisp-utils.scm
@@ -84,11 +84,12 @@
 (define (normalize-dependency dependency)
   "Normalize the name of DEPENDENCY.  Handles dependency definitions of the
 dependency-def form described by
-<https://common-lisp.net/project/asdf/asdf.html#The-defsystem-grammar>."
+<https://common-lisp.net/project/asdf/asdf.html#The-defsystem-grammar>.
+Assume that any symbols in DEPENDENCY will be in upper-case."
   (match dependency
-    ((':version name rest ...)
+    ((':VERSION name rest ...)
      `(:version ,(normalize-string name) ,@rest))
-    ((':feature feature-specification dependency-specification)
+    ((':FEATURE feature-specification dependency-specification)
      `(:feature
        ,feature-specification
        ,(normalize-dependency dependency-specification)))
diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm
index afd5d997ae..1c1e73a723 100644
--- a/guix/import/stackage.scm
+++ b/guix/import/stackage.scm
@@ -43,15 +43,12 @@
 
 (define (lts-info-ghc-version lts-info)
   "Retruns the version of the GHC compiler contained in LTS-INFO."
-  (match lts-info
-    ((("snapshot" ("ghc" . version) _ _) _)  version)
-    (_ #f)))
+  (and=> (assoc-ref lts-info "snapshot")
+         (cut assoc-ref <> "ghc")))
 
 (define (lts-info-packages lts-info)
-  "Returns the alist of packages contained in LTS-INFO."
-  (match lts-info
-    ((("packages" pkg ...) . _) pkg)
-    (_ '())))
+  "Retruns the alist of packages contained in LTS-INFO."
+  (or (assoc-ref lts-info "packages") '()))
 
 (define (leave-with-message fmt . args)
   (raise (condition (&message (message (apply format #f fmt args))))))
diff --git a/guix/progress.scm b/guix/progress.scm
index 53aea1c56d..f846944952 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,7 +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
 
@@ -183,6 +187,46 @@ width of the bar is BAR-WIDTH."
 move the cursor to the beginning of the line."
   (display "\r\x1b[K" port))
 
+(define* (display-download-progress file size
+                                    #:key
+                                    start-time (transferred 0)
+                                    (log-port (current-error-port)))
+  "Write the progress report to LOG-PORT.  Use START-TIME (a SRFI-19 time
+object) and TRANSFERRED (a total number of bytes) to determine the
+throughput."
+  (define elapsed
+    (duration->seconds
+     (time-difference (current-time time-monotonic) start-time)))
+  (if (number? size)
+      (let* ((%  (* 100.0 (/ transferred size)))
+             (throughput (/ transferred elapsed))
+             (left       (format #f " ~a  ~a" file
+                                 (byte-count->string size)))
+             (right      (format #f "~a/s ~a ~a~6,1f%"
+                                 (byte-count->string throughput)
+                                 (seconds->string elapsed)
+                                 (progress-bar %) %)))
+        (erase-current-line log-port)
+        (display (string-pad-middle left right
+                                    (current-terminal-columns))
+                 log-port)
+        (force-output log-port))
+      (let* ((throughput (/ transferred elapsed))
+             (left       (format #f " ~a" file))
+             (right      (format #f "~a/s ~a | ~a transferred"
+                                 (byte-count->string throughput)
+                                 (seconds->string elapsed)
+                                 (byte-count->string transferred))))
+        (erase-current-line log-port)
+        (display (string-pad-middle left right
+                                    (current-terminal-columns))
+                 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))
@@ -192,44 +236,16 @@ ABBREVIATION used to shorten FILE for display."
   (let ((start-time (current-time time-monotonic))
         (transferred 0))
     (define (render)
-      "Write the progress report to LOG-PORT."
-      (define elapsed
-        (duration->seconds
-         (time-difference (current-time time-monotonic) start-time)))
-      (if (number? size)
-          (let* ((%  (* 100.0 (/ transferred size)))
-                 (throughput (/ transferred elapsed))
-                 (left       (format #f " ~a  ~a"
-                                     (abbreviation file)
-                                     (byte-count->string size)))
-                 (right      (format #f "~a/s ~a ~a~6,1f%"
-                                     (byte-count->string throughput)
-                                     (seconds->string elapsed)
-                                     (progress-bar %) %)))
-            (erase-current-line log-port)
-            (display (string-pad-middle left right
-                                        (current-terminal-columns))
-                     log-port)
-            (force-output log-port))
-          (let* ((throughput (/ transferred elapsed))
-                 (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))))
-            (erase-current-line log-port)
-            (display (string-pad-middle left right
-                                        (current-terminal-columns))
-                     log-port)
-            (force-output log-port))))
+      (display-download-progress (abbreviation file) size
+                                 #:start-time start-time
+                                 #:transferred transferred
+                                 #:log-port log-port))
 
     (progress-reporter
      (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))))
@@ -269,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 ()
+           (let ((size (or (and=> (stat file #f) stat:size)
+                           size)))
+             (report-progress size)
+             (display (format #f "@ download-succeeded ~a ~a ~a~%"
+                              file url 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..df787a9940 100644
--- a/guix/scripts/perform-download.scm
+++ b/guix/scripts/perform-download.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -41,7 +41,8 @@
     (module-use! module (resolve-interface '(guix base32)))
     module))
 
-(define* (perform-download drv #:optional output)
+(define* (perform-download drv #:optional output
+                           #:key print-build-trace?)
   "Perform the download described by DRV, a fixed-output derivation, to
 OUTPUT.
 
@@ -67,6 +68,7 @@ actual output is different from that when we're doing a 'bmCheck' or
 
       ;; We're invoked by the daemon, which gives us write access to OUTPUT.
       (when (url-fetch url output
+                       #:print-build-trace? print-build-trace?
                        #:mirrors (if mirrors
                                      (call-with-input-file mirrors read)
                                      '())
@@ -98,6 +100,11 @@ allows us to sidestep bootstrapping problems, such downloading the source code
 of GnuTLS over HTTPS, before we have built GnuTLS.  See
 <http://bugs.gnu.org/22774>."
 
+  (define print-build-trace?
+    (match (getenv "_NIX_OPTIONS")
+      (#f #f)
+      (str (string-contains str "print-extended-build-trace=1"))))
+
   ;; This program must be invoked by guix-daemon under an unprivileged UID to
   ;; prevent things downloading from 'file:///etc/shadow' or arbitrary code
   ;; execution via the content-addressed mirror procedures.  (That means we
@@ -107,10 +114,12 @@ of GnuTLS over HTTPS, before we have built GnuTLS.  See
       (((? derivation-path? drv) (? store-path? output))
        (assert-low-privileges)
        (perform-download (read-derivation-from-file drv)
-                         output))
+                         output
+                         #:print-build-trace? print-build-trace?))
       (((? derivation-path? drv))                 ;backward compatibility
        (assert-low-privileges)
-       (perform-download (read-derivation-from-file drv)))
+       (perform-download (read-derivation-from-file drv)
+                         #:print-build-trace? print-build-trace?))
       (("--version")
        (show-version-and-exit))
       (x
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 69bd05b516..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)
@@ -310,9 +311,9 @@ names of services to load (upgrade), and the list of names of services to
 unload."
   (match (current-services)
     ((services ...)
-     (let-values (((to-unload to-load)
+     (let-values (((to-unload to-restart)
                    (shepherd-service-upgrade services new-services)))
-       (mproc to-load
+       (mproc to-restart
               (map (compose first live-service-provision)
                    to-unload))))
     (#f
@@ -335,25 +336,32 @@ bring the system down."
   ;; Arrange to simply emit a warning if the service upgrade fails.
   (with-shepherd-error-handling
    (call-with-service-upgrade-info new-services
-     (lambda (to-load to-unload)
+     (lambda (to-restart to-unload)
         (for-each (lambda (unload)
                     (info (G_ "unloading service '~a'...~%") unload)
                     (unload-service unload))
                   to-unload)
 
         (with-monad %store-monad
-          (munless (null? to-load)
-            (let ((to-load-names  (map shepherd-service-canonical-name to-load))
-                  (to-start       (filter shepherd-service-auto-start? to-load)))
-              (info (G_ "loading new services:~{ ~a~}...~%") to-load-names)
+          (munless (null? new-services)
+            (let ((new-service-names  (map shepherd-service-canonical-name new-services))
+                  (to-restart-names   (map shepherd-service-canonical-name to-restart))
+                  (to-start           (filter shepherd-service-auto-start? new-services)))
+              (info (G_ "loading new services:~{ ~a~}...~%") new-service-names)
+              (unless (null? to-restart-names)
+                ;; Listing TO-RESTART-NAMES in the message below wouldn't help
+                ;; because many essential services cannot be meaningfully
+                ;; restarted.  See <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=22039#30>.
+                (format #t (G_ "To complete the upgrade, run 'herd restart SERVICE' to stop,
+upgrade, and restart each service that was not automatically restarted.\n")))
               (mlet %store-monad ((files (mapm %store-monad
                                                (compose lower-object
                                                         shepherd-service-file)
-                                               to-load)))
+                                               new-services)))
                 ;; Here we assume that FILES are exactly those that were computed
                 ;; as part of the derivation that built OS, which is normally the
                 ;; case.
-                (load-services (map derivation->output-path files))
+                (load-services/safe (map derivation->output-path files))
 
                 (for-each start-service
                           (map shepherd-service-canonical-name to-start))
@@ -1072,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")
@@ -1246,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..c6956066fd
--- /dev/null
+++ b/guix/status.scm
@@ -0,0 +1,501 @@
+;;; 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)
+  #: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  MAGENTA   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)
+     (match (derivation-log-file drv)
+       (#f
+        (format port (failure (G_ "Could not find build log for '~a'."))
+                drv))
+       (log
+        (format port (info (G_ "View build log at '~a'.")) log)))
+     (newline port))
+    (('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)
+     ;; TODO: Better distinguish daemon messages and build log lines.
+     (cond ((string-prefix? "substitute: " line)
+            ;; The daemon prefixes early messages coming with 'guix
+            ;; substitute' with "substitute:".  These are useful ("updating
+            ;; substitutes from URL"), so let them through.
+            (format port line)
+            (force-output port))
+           ((string-prefix? "waiting for locks" line)
+            ;; This is when a derivation is already being built and we're just
+            ;; waiting for the build to complete.
+            (display (info (string-trim-right line)) port)
+            (newline))
+           (else
+            (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..8b35fc8d7a 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?
@@ -150,9 +152,10 @@
             store-path-package-name
             store-path-hash-part
             direct-store-path
+            derivation-log-file
             log-file))
 
-(define %protocol-version #x161)
+(define %protocol-version #x162)
 
 (define %worker-magic-1 #x6e697863)               ; "nixc"
 (define %worker-magic-2 #x6478696f)               ; "dxio"
@@ -161,6 +164,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 +545,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 +566,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 +702,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 +752,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 +1096,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.
@@ -1673,21 +1707,26 @@ syntactically valid store path."
                 (and (string-every %nix-base32-charset hash)
                      hash))))))
 
+(define (derivation-log-file drv)
+  "Return the build log file for DRV, a derivation file name, or #f if it
+could not be found."
+  (let* ((base    (basename drv))
+         (log     (string-append (dirname %state-directory) ; XXX
+                                 "/log/guix/drvs/"
+                                 (string-take base 2) "/"
+                                 (string-drop base 2)))
+         (log.gz  (string-append log ".gz"))
+         (log.bz2 (string-append log ".bz2")))
+    (cond ((file-exists? log.gz) log.gz)
+          ((file-exists? log.bz2) log.bz2)
+          ((file-exists? log) log)
+          (else #f))))
+
 (define (log-file store file)
   "Return the build log file for FILE, or #f if none could be found.  FILE
 must be an absolute store file name, or a derivation file name."
   (cond ((derivation-path? file)
-         (let* ((base    (basename file))
-                (log     (string-append (dirname %state-directory) ; XXX
-                                        "/log/guix/drvs/"
-                                        (string-take base 2) "/"
-                                        (string-drop base 2)))
-                (log.gz  (string-append log ".gz"))
-                (log.bz2 (string-append log ".bz2")))
-           (cond ((file-exists? log.gz) log.gz)
-                 ((file-exists? log.bz2) log.bz2)
-                 ((file-exists? log) log)
-                 (else #f))))
+         (derivation-log-file file))
         (else
          (match (valid-derivers store file)
            ((derivers ...)
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