Merge branch 'core-updates' into core-updates-next

36 files changed, 1777 insertions, 550 deletions

diff --git a/guix/build-system/glib-or-gtk.scm b/guix/build-system/glib-or-gtk.scm
index 621e68e0ab..fcd92f2334 100644
--- a/guix/build-system/glib-or-gtk.scm
+++ b/guix/build-system/glib-or-gtk.scm
@@ -112,7 +112,7 @@
                             (configure-flags ''())
                             ;; Disable icon theme cache generation.
                             (make-flags ''("gtk_update_icon_cache=true"))
-                            (out-of-source? #t)
+                            (out-of-source? #f)
                             (tests? #t)
                             (test-target "check")
                             (parallel-build? #t)
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-system/python.scm b/guix/build-system/python.scm
index ffed837313..b753940bad 100644
--- a/guix/build-system/python.scm
+++ b/guix/build-system/python.scm
@@ -50,7 +50,7 @@
   "Return a URI string for the Python package hosted on the Python Package
 Index (PyPI) corresponding to NAME and VERSION.  EXTENSION is the file name
 extension, such as '.tar.gz'."
-  (string-append "https://pypi.io/packages/source/"
+  (string-append "https://pypi.org/packages/source/"
                  (string-take name 1) "/" name "/"
                  name "-" version extension))
 
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..7b556f6431 100644
--- a/guix/build/haskell-build-system.scm
+++ b/guix/build/haskell-build-system.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2015 Paul van der Walt <paul@denknerd.org>
 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,6 +29,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))
 
@@ -77,6 +79,7 @@ and parameters ~s~%"
          (doc (assoc-ref outputs "doc"))
          (lib (assoc-ref outputs "lib"))
          (bin (assoc-ref outputs "bin"))
+         (name-version (strip-store-file-name out))
          (input-dirs (match inputs
                        (((_ . dir) ...)
                         dir)
@@ -87,7 +90,7 @@ and parameters ~s~%"
                          `(,(string-append "--bindir=" (or bin out) "/bin"))
                          `(,(string-append
                              "--docdir=" (or doc out)
-                             "/share/doc/" (package-name-version out)))
+                             "/share/doc/" name-version))
                          '("--libsubdir=$compiler/$pkg-$version")
                          `(,(string-append "--package-db=" %tmp-db-dir))
                          '("--global")
@@ -126,12 +129,6 @@ and parameters ~s~%"
   "Install a given Haskell package."
   (run-setuphs "copy" '()))
 
-(define (package-name-version store-dir)
-  "Given a store directory STORE-DIR return 'name-version' of the package."
-  (let* ((base (basename store-dir)))
-    (string-drop base
-                 (+ 1 (string-index base #\-)))))
-
 (define (grep rx port)
   "Given a regular-expression RX including a group, read from PORT until the
 first match and return the content of the group."
@@ -146,7 +143,7 @@ first match and return the content of the group."
 (define* (setup-compiler #:key system inputs outputs #:allow-other-keys)
   "Setup the compiler environment."
   (let* ((haskell (assoc-ref inputs "haskell"))
-         (name-version (package-name-version haskell)))
+         (name-version (strip-store-file-name haskell)))
     (cond
      ((string-match "ghc" name-version)
       (make-ghc-package-database system inputs outputs))
@@ -163,6 +160,7 @@ first match and return the content of the group."
 (define (make-ghc-package-database system inputs outputs)
   "Generate the GHC package database."
   (let* ((haskell  (assoc-ref inputs "haskell"))
+         (name-version (strip-store-file-name haskell))
          (input-dirs (match inputs
                        (((_ . dir) ...)
                         dir)
@@ -170,7 +168,7 @@ first match and return the content of the group."
          ;; Silence 'find-files' (see 'evaluate-search-paths')
          (conf-dirs (with-null-error-port
                      (search-path-as-list
-                      `(,(string-append "lib/" (package-name-version haskell)))
+                      `(,(string-append "lib/" name-version))
                       input-dirs #:pattern ".*\\.conf.d$")))
          (conf-files (append-map (cut find-files <> "\\.conf$") conf-dirs)))
     (mkdir-p %tmp-db-dir)
@@ -230,9 +228,10 @@ given Haskell package."
 
   (let* ((out (assoc-ref outputs "out"))
          (haskell  (assoc-ref inputs "haskell"))
+         (name-verion (strip-store-file-name haskell))
          (lib (string-append out "/lib"))
-         (config-dir (string-append lib "/"
-                                    (package-name-version haskell)
+         (config-dir (string-append lib
+                                    "/" name-verion
                                     "/" name ".conf.d"))
          (id-rx (make-regexp "^id: *(.*)$"))
          (config-file (string-append out "/" name ".conf"))
@@ -266,8 +265,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/java-utils.scm b/guix/build/java-utils.scm
index 128be1edeb..8200638bee 100644
--- a/guix/build/java-utils.scm
+++ b/guix/build/java-utils.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
 ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -23,12 +24,6 @@
             install-jars
             install-javadoc))
 
-;; Copied from haskell-build-system.scm
-(define (package-name-version store-dir)
-  "Given a store directory STORE-DIR return 'name-version' of the package."
-  (let* ((base (basename store-dir)))
-    (string-drop base (+ 1 (string-index base #\-)))))
-
 (define* (ant-build-javadoc #:key (target "javadoc") (make-flags '())
                             #:allow-other-keys)
   (apply invoke `("ant" ,target ,@make-flags)))
@@ -48,8 +43,9 @@ is used in case the build.xml does not include an install target."
 install javadocs when this is not done by the install target."
   (lambda* (#:key outputs #:allow-other-keys)
     (let* ((out (assoc-ref outputs "out"))
+           (name-version (strip-store-file-name out))
            (docs (string-append (or (assoc-ref outputs "doc") out)
-                                "/share/doc/" (package-name-version out) "/")))
+                                "/share/doc/" name-version "/")))
       (mkdir-p docs)
       (copy-recursively apidoc-directory docs)
       #t)))
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/build/store-copy.scm b/guix/build/store-copy.scm
index 2d9590d16f..64ade7885c 100644
--- a/guix/build/store-copy.scm
+++ b/guix/build/store-copy.scm
@@ -19,6 +19,7 @@
 (define-module (guix build store-copy)
   #:use-module (guix build utils)
   #:use-module (guix sets)
+  #:use-module (guix progress)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
@@ -167,7 +168,8 @@ REFERENCE-GRAPHS, a list of reference-graph files."
 
   (reduce + 0 (map file-size items)))
 
-(define* (populate-store reference-graphs target)
+(define* (populate-store reference-graphs target
+                         #:key (log-port (current-error-port)))
   "Populate the store under directory TARGET with the items specified in
 REFERENCE-GRAPHS, a list of reference-graph files."
   (define store
@@ -183,9 +185,20 @@ REFERENCE-GRAPHS, a list of reference-graph files."
 
   (mkdir-p store)
   (chmod store #o1775)
-  (for-each (lambda (thing)
-              (copy-recursively thing
-                                (string-append target thing)))
-            (things-to-copy)))
+
+  (let* ((things   (things-to-copy))
+         (len      (length things))
+         (progress (progress-reporter/bar len
+                                          (format #f "copying ~a store items"
+                                                  len)
+                                          log-port)))
+    (call-with-progress-reporter progress
+      (lambda (report)
+        (for-each (lambda (thing)
+                    (copy-recursively thing
+                                      (string-append target thing)
+                                      #:log (%make-void-port "w"))
+                    (report))
+                  things)))))
 
 ;;; store-copy.scm ends here
diff --git a/guix/channels.scm b/guix/channels.scm
index 2e7bffae9f..82389eb583 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -47,9 +47,9 @@
             channel-instance-checkout
 
             latest-channel-instances
-            channel-instance-derivations
             latest-channel-derivation
-            channel-instances->manifest))
+            channel-instances->manifest
+            channel-instances->derivation))
 
 ;;; Commentary:
 ;;;
@@ -294,13 +294,17 @@ channel instances."
                                           (zip instances derivations))))
     (return (manifest entries))))
 
+(define (channel-instances->derivation instances)
+  "Return the derivation of the profile containing INSTANCES, a list of
+channel instances."
+  (mlet %store-monad ((manifest (channel-instances->manifest instances)))
+    (profile-derivation manifest)))
+
 (define latest-channel-instances*
   (store-lift latest-channel-instances))
 
 (define* (latest-channel-derivation #:optional (channels %default-channels))
   "Return as a monadic value the derivation that builds the profile for the
 latest instances of CHANNELS."
-  (mlet* %store-monad ((instances ((store-lift latest-channel-instances)
-                                   channels))
-                       (manifest  (channel-instances->manifest instances)))
-    (profile-derivation manifest)))
+  (mlet %store-monad ((instances (latest-channel-instances* channels)))
+    (channel-instances->derivation instances)))
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 770b79e012..f7def5862b 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -438,6 +438,14 @@ This is the declarative counterpart of 'gexp->file'."
   (base   file-append-base)                    ;<package> | <derivation> | ...
   (suffix file-append-suffix))                 ;list of strings
 
+(define (write-file-append file port)
+  (match file
+    (($ <file-append> base suffix)
+     (format port "#<file-append ~s ~s>" base
+             (string-join suffix)))))
+
+(set-record-type-printer! <file-append> write-file-append)
+
 (define (file-append base . suffix)
   "Return a <file-append> object that expands to the concatenation of BASE and
 SUFFIX."
diff --git a/guix/git-download.scm b/guix/git-download.scm
index 24cf11be5e..fa94fad8f8 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -156,22 +156,23 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
 The result is similar to that of the 'git ls-files' command, except that it
 also includes directories, not just regular files.  The returned file names
 are relative to DIRECTORY, which is not necessarily the root of the checkout."
-  (let* ((directory  (canonicalize-path directory))
+  (let* (;; 'repository-working-directory' always returns a trailing "/",
+         ;; so add one here to ease the comparisons below.
+         (directory  (string-append (canonicalize-path directory) "/"))
          (dot-git    (repository-discover directory))
-         (top        (dirname dot-git))
          (repository (repository-open dot-git))
+         ;; XXX: This procedure is mistakenly private in Guile-Git 0.1.0.
+         (workdir    ((@@ (git repository) repository-working-directory)
+                      repository))
          (head       (repository-head repository))
          (oid        (reference-target head))
          (commit     (commit-lookup repository oid))
          (tree       (commit-tree commit))
          (files      (tree-list tree)))
     (repository-close! repository)
-    (if (string=? top directory)
+    (if (string=? workdir directory)
         files
-        (let ((relative (string-append
-                         (string-drop directory
-                                      (+ 1 (string-length top)))
-                         "/")))
+        (let ((relative (string-drop directory (string-length workdir))))
           (filter-map (lambda (file)
                         (and (string-prefix? relative file)
                              (string-drop file (string-length relative))))
diff --git a/guix/gnupg.scm b/guix/gnupg.scm
index b30ce461b4..40feb44561 100644
--- a/guix/gnupg.scm
+++ b/guix/gnupg.scm
@@ -57,7 +57,7 @@
 (define %openpgp-key-server
   ;; The default key server.  Note that keys.gnupg.net appears to be
   ;; unreliable.
-  (make-parameter "pgp.mit.edu"))
+  (make-parameter "pool.sks-keyservers.net"))
 
 (define* (gnupg-verify sig file
                        #:optional (keyring (current-keyring)))
diff --git a/guix/import/json.scm b/guix/import/json.scm
index 4f96a513df..81ea5e7b31 100644
--- a/guix/import/json.scm
+++ b/guix/import/json.scm
@@ -47,4 +47,5 @@ the query."
 (define (json-fetch-alist url)
   "Return an alist representation of the JSON resource URL, or #f if URL
 returns 403 or 404."
-  (hash-table->alist (json-fetch url)))
+  (and=> (json-fetch url)
+         hash-table->alist))
diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm
index 87b047bdac..3a20fc4b9b 100644
--- a/guix/import/pypi.scm
+++ b/guix/import/pypi.scm
@@ -330,7 +330,7 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
   (define (pypi-url? url)
     (or (string-prefix? "https://pypi.org/" url)
         (string-prefix? "https://pypi.python.org/" url)
-        (string-prefix? "https://pypi.io/packages" url)))
+        (string-prefix? "https://pypi.org/packages" url)))
 
   (let ((source-url (and=> (package-source package) origin-uri))
         (fetch-method (and=> (package-source package) origin-method)))
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/inferior.scm b/guix/inferior.scm
index af37233a03..1dbb9e1699 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -19,24 +19,68 @@
 (define-module (guix inferior)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
-  #:use-module ((guix utils) #:select (source-properties->location))
+  #:use-module ((guix utils)
+                #:select (%current-system
+                          source-properties->location
+                          call-with-temporary-directory
+                          version>? version-prefix?
+                          cache-directory))
+  #:use-module ((guix store)
+                #:select (nix-server-socket
+                          nix-server-major-version
+                          nix-server-minor-version
+                          store-lift))
+  #:use-module ((guix derivations)
+                #:select (read-derivation-from-file))
+  #:use-module (guix gexp)
+  #:use-module (guix search-paths)
+  #:use-module (guix profiles)
+  #:use-module (guix channels)
+  #:use-module (guix monads)
+  #:use-module (guix store)
+  #:use-module (guix derivations)
+  #:use-module (guix base32)
+  #:use-module (gcrypt hash)
+  #:autoload   (guix cache) (maybe-remove-expired-cache-entries)
+  #:autoload   (guix ui) (show-what-to-build*)
+  #:autoload   (guix build utils) (mkdir-p)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:autoload   (ice-9 ftw) (scandir)
   #:use-module (ice-9 match)
   #:use-module (ice-9 popen)
+  #:use-module (ice-9 vlist)
+  #:use-module (ice-9 binary-ports)
+  #:use-module ((rnrs bytevectors) #:select (string->utf8))
   #:export (inferior?
             open-inferior
             close-inferior
             inferior-eval
             inferior-object?
 
+            inferior-packages
+            lookup-inferior-packages
+
             inferior-package?
             inferior-package-name
             inferior-package-version
-
-            inferior-packages
             inferior-package-synopsis
             inferior-package-description
             inferior-package-home-page
-            inferior-package-location))
+            inferior-package-location
+            inferior-package-inputs
+            inferior-package-native-inputs
+            inferior-package-propagated-inputs
+            inferior-package-transitive-propagated-inputs
+            inferior-package-native-search-paths
+            inferior-package-transitive-native-search-paths
+            inferior-package-search-paths
+            inferior-package-derivation
+
+            inferior-package->manifest-entry
+
+            %inferior-cache-directory
+            inferior-for-channels))
 
 ;;; Commentary:
 ;;;
@@ -48,11 +92,13 @@
 
 ;; Inferior Guix process.
 (define-record-type <inferior>
-  (inferior pid socket version)
+  (inferior pid socket version packages table)
   inferior?
   (pid      inferior-pid)
   (socket   inferior-socket)
-  (version  inferior-version))                    ;REPL protocol version
+  (version  inferior-version)                    ;REPL protocol version
+  (packages inferior-package-promise)            ;promise of inferior packages
+  (table    inferior-package-table))             ;promise of vhash
 
 (define (inferior-pipe directory command)
   "Return an input/output pipe on the Guix instance in DIRECTORY.  This runs
@@ -96,9 +142,12 @@ equivalent.  Return #f if the inferior could not be launched."
 
   (match (read pipe)
     (('repl-version 0 rest ...)
-     (let ((result (inferior 'pipe pipe (cons 0 rest))))
+     (letrec ((result (inferior 'pipe pipe (cons 0 rest)
+                                (delay (%inferior-packages result))
+                                (delay (%inferior-package-table result)))))
        (inferior-eval '(use-modules (guix)) result)
        (inferior-eval '(use-modules (gnu)) result)
+       (inferior-eval '(use-modules (ice-9 match)) result)
        (inferior-eval '(define %package-table (make-hash-table))
                       result)
        result))
@@ -123,8 +172,7 @@ equivalent.  Return #f if the inferior could not be launched."
 
 (set-record-type-printer! <inferior-object> write-inferior-object)
 
-(define (inferior-eval exp inferior)
-  "Evaluate EXP in INFERIOR."
+(define (read-inferior-response inferior)
   (define sexp->object
     (match-lambda
       (('value value)
@@ -132,14 +180,21 @@ equivalent.  Return #f if the inferior could not be launched."
       (('non-self-quoting address string)
        (inferior-object address string))))
 
-  (write exp (inferior-socket inferior))
-  (newline (inferior-socket inferior))
   (match (read (inferior-socket inferior))
     (('values objects ...)
      (apply values (map sexp->object objects)))
     (('exception key objects ...)
      (apply throw key (map sexp->object objects)))))
 
+(define (send-inferior-request exp inferior)
+  (write exp (inferior-socket inferior))
+  (newline (inferior-socket inferior)))
+
+(define (inferior-eval exp inferior)
+  "Evaluate EXP in INFERIOR."
+  (send-inferior-request exp inferior)
+  (read-inferior-response inferior))
+
 
 ;;;
 ;;; Inferior packages.
@@ -162,8 +217,8 @@ equivalent.  Return #f if the inferior could not be launched."
 
 (set-record-type-printer! <inferior-package> write-inferior-package)
 
-(define (inferior-packages inferior)
-  "Return the list of packages known to INFERIOR."
+(define (%inferior-packages inferior)
+  "Compute the list of inferior packages from INFERIOR."
   (let ((result (inferior-eval
                  '(fold-packages (lambda (package result)
                                    (let ((id (object-address package)))
@@ -179,6 +234,33 @@ equivalent.  Return #f if the inferior could not be launched."
             (inferior-package inferior name version id)))
          result)))
 
+(define (inferior-packages inferior)
+  "Return the list of packages known to INFERIOR."
+  (force (inferior-package-promise inferior)))
+
+(define (%inferior-package-table inferior)
+  "Compute a package lookup table for INFERIOR."
+  (fold (lambda (package table)
+          (vhash-cons (inferior-package-name package) package
+                      table))
+        vlist-null
+        (inferior-packages inferior)))
+
+(define* (lookup-inferior-packages inferior name #:optional version)
+  "Return the sorted list of inferior packages matching NAME in INFERIOR, with
+highest version numbers first.  If VERSION is true, return only packages with
+a version number prefixed by VERSION."
+  ;; This is the counterpart of 'find-packages-by-name'.
+  (sort (filter (lambda (package)
+                  (or (not version)
+                      (version-prefix? version
+                                       (inferior-package-version package))))
+                (vhash-fold* cons '() name
+                             (force (inferior-package-table inferior))))
+        (lambda (p1 p2)
+          (version>? (inferior-package-version p1)
+                     (inferior-package-version p2)))))
+
 (define (inferior-package-field package getter)
   "Return the field of PACKAGE, an inferior package, accessed with GETTER."
   (let ((inferior (inferior-package-inferior package))
@@ -216,3 +298,261 @@ record."
                                             (location->source-properties
                                              loc)))
                                      package-location))))
+
+(define (inferior-package-input-field package field)
+  "Return the input field FIELD (e.g., 'native-inputs') of PACKAGE, an
+inferior package."
+  (define field*
+    `(compose (lambda (inputs)
+                (map (match-lambda
+                       ;; XXX: Origins are not handled.
+                       ((label (? package? package) rest ...)
+                        (let ((id (object-address package)))
+                          (hashv-set! %package-table id package)
+                          `(,label (package ,id
+                                            ,(package-name package)
+                                            ,(package-version package))
+                                   ,@rest)))
+                       (x
+                        x))
+                     inputs))
+              ,field))
+
+  (define inputs
+    (inferior-package-field package field*))
+
+  (define inferior
+    (inferior-package-inferior package))
+
+  (map (match-lambda
+         ((label ('package id name version) . rest)
+          ;; XXX: eq?-ness of inferior packages is not preserved here.
+          `(,label ,(inferior-package inferior name version id)
+                   ,@rest))
+         (x x))
+       inputs))
+
+(define inferior-package-inputs
+  (cut inferior-package-input-field <> 'package-inputs))
+
+(define inferior-package-native-inputs
+  (cut inferior-package-input-field <> 'package-native-inputs))
+
+(define inferior-package-propagated-inputs
+  (cut inferior-package-input-field <> 'package-propagated-inputs))
+
+(define inferior-package-transitive-propagated-inputs
+  (cut inferior-package-input-field <> 'package-transitive-propagated-inputs))
+
+(define (%inferior-package-search-paths package field)
+  "Return the list of search path specificiations of PACKAGE, an inferior
+package."
+  (define paths
+    (inferior-package-field package
+                            `(compose (lambda (paths)
+                                        (map (@ (guix search-paths)
+                                                search-path-specification->sexp)
+                                             paths))
+                                      ,field)))
+
+  (map sexp->search-path-specification paths))
+
+(define inferior-package-native-search-paths
+  (cut %inferior-package-search-paths <> 'package-native-search-paths))
+
+(define inferior-package-search-paths
+  (cut %inferior-package-search-paths <> 'package-search-paths))
+
+(define inferior-package-transitive-native-search-paths
+  (cut %inferior-package-search-paths <> 'package-transitive-native-search-paths))
+
+(define (proxy client backend)                    ;adapted from (guix ssh)
+  "Proxy communication between CLIENT and BACKEND until CLIENT closes the
+connection, at which point CLIENT is closed (both CLIENT and BACKEND must be
+input/output ports.)"
+  (define (select* read write except)
+    ;; This is a workaround for <https://bugs.gnu.org/30365> in Guile < 2.2.4:
+    ;; since 'select' sometimes returns non-empty sets for no good reason,
+    ;; call 'select' a second time with a zero timeout to filter out incorrect
+    ;; replies.
+    (match (select read write except)
+      ((read write except)
+       (select read write except 0))))
+
+  ;; Use buffered ports so that 'get-bytevector-some' returns up to the
+  ;; whole buffer like read(2) would--see <https://bugs.gnu.org/30066>.
+  (setvbuf client _IOFBF 65536)
+  (setvbuf backend _IOFBF 65536)
+
+  (let loop ()
+    (match (select* (list client backend) '() '())
+      ((reads () ())
+       (when (memq client reads)
+         (match (get-bytevector-some client)
+           ((? eof-object?)
+            (close-port client))
+           (bv
+            (put-bytevector backend bv)
+            (force-output backend))))
+       (when (memq backend reads)
+         (match (get-bytevector-some backend)
+           (bv
+            (put-bytevector client bv)
+            (force-output client))))
+       (unless (port-closed? client)
+         (loop))))))
+
+(define* (inferior-package-derivation store package
+                                      #:optional
+                                      (system (%current-system))
+                                      #:key target)
+  "Return the derivation for PACKAGE, an inferior package, built for SYSTEM
+and cross-built for TARGET if TARGET is true.  The inferior corresponding to
+PACKAGE must be live."
+  ;; Create a named socket in /tmp and let the inferior of PACKAGE connect to
+  ;; it and use it as its store.  This ensures the inferior uses the same
+  ;; store, with the same options, the same per-session GC roots, etc.
+  (call-with-temporary-directory
+   (lambda (directory)
+     (chmod directory #o700)
+     (let* ((name     (string-append directory "/inferior"))
+            (socket   (socket AF_UNIX SOCK_STREAM 0))
+            (inferior (inferior-package-inferior package))
+            (major    (nix-server-major-version store))
+            (minor    (nix-server-minor-version store))
+            (proto    (logior major minor)))
+       (bind socket AF_UNIX name)
+       (listen socket 1024)
+       (send-inferior-request
+        `(let ((socket (socket AF_UNIX SOCK_STREAM 0)))
+           (connect socket AF_UNIX ,name)
+
+           ;; 'port->connection' appeared in June 2018 and we can hardly
+           ;; emulate it on older versions.  Thus fall back to
+           ;; 'open-connection', at the risk of talking to the wrong daemon or
+           ;; having our build result reclaimed (XXX).
+           (let* ((store   (if (defined? 'port->connection)
+                               (port->connection socket #:version ,proto)
+                               (open-connection)))
+                  (package (hashv-ref %package-table
+                                      ,(inferior-package-id package)))
+                  (drv     ,(if target
+                                `(package-cross-derivation store package
+                                                           ,target
+                                                           ,system)
+                                `(package-derivation store package
+                                                     ,system))))
+             (close-connection store)
+             (close-port socket)
+             (derivation-file-name drv)))
+        inferior)
+       (match (accept socket)
+         ((client . address)
+          (proxy client (nix-server-socket store))))
+       (close-port socket)
+       (read-derivation-from-file (read-inferior-response inferior))))))
+
+(define inferior-package->derivation
+  (store-lift inferior-package-derivation))
+
+(define-gexp-compiler (package-compiler (package <inferior-package>) system
+                                        target)
+  ;; Compile PACKAGE for SYSTEM, optionally cross-building for TARGET.
+  (inferior-package->derivation package system #:target target))
+
+
+;;;
+;;; Manifest entries.
+;;;
+
+(define* (inferior-package->manifest-entry package
+                                           #:optional (output "out")
+                                           #:key (parent (delay #f))
+                                           (properties '()))
+  "Return a manifest entry for the OUTPUT of package PACKAGE."
+  ;; For each dependency, keep a promise pointing to its "parent" entry.
+  (letrec* ((deps  (map (match-lambda
+                          ((label package)
+                           (inferior-package->manifest-entry package
+                                                             #:parent (delay entry)))
+                          ((label package output)
+                           (inferior-package->manifest-entry package output
+                                                             #:parent (delay entry))))
+                        (inferior-package-propagated-inputs package)))
+            (entry (manifest-entry
+                     (name (inferior-package-name package))
+                     (version (inferior-package-version package))
+                     (output output)
+                     (item package)
+                     (dependencies (delete-duplicates deps))
+                     (search-paths
+                      (inferior-package-transitive-native-search-paths package))
+                     (parent parent)
+                     (properties properties))))
+    entry))
+
+
+;;;
+;;; Cached inferiors.
+;;;
+
+(define %inferior-cache-directory
+  ;; Directory for cached inferiors (GC roots).
+  (make-parameter (string-append (cache-directory #:ensure? #f)
+                                 "/inferiors")))
+
+(define* (inferior-for-channels channels
+                                #:key
+                                (cache-directory (%inferior-cache-directory))
+                                (ttl (* 3600 24 30)))
+  "Return an inferior for CHANNELS, a list of channels.  Use the cache at
+CACHE-DIRECTORY, where entries can be reclaimed after TTL seconds.  This
+procedure opens a new connection to the build daemon.
+
+This is a convenience procedure that people may use in manifests passed to
+'guix package -m', for instance."
+  (with-store store
+    (let ()
+      (define instances
+        (latest-channel-instances store channels))
+
+      (define key
+        (bytevector->base32-string
+         (sha256
+          (string->utf8
+           (string-concatenate (map channel-instance-commit instances))))))
+
+      (define cached
+        (string-append cache-directory "/" key))
+
+      (define (base32-encoded-sha256? str)
+        (= (string-length str) 52))
+
+      (define (cache-entries directory)
+        (map (lambda (file)
+               (string-append directory "/" file))
+             (scandir directory base32-encoded-sha256?)))
+
+      (define symlink*
+        (lift2 symlink %store-monad))
+
+      (define add-indirect-root*
+        (store-lift add-indirect-root))
+
+      (mkdir-p cache-directory)
+      (maybe-remove-expired-cache-entries cache-directory
+                                          cache-entries
+                                          #:entry-expiration
+                                          (file-expiration-time ttl))
+
+      (if (file-exists? cached)
+          (open-inferior cached)
+          (run-with-store store
+            (mlet %store-monad ((profile
+                                 (channel-instances->derivation instances)))
+              (mbegin %store-monad
+                (show-what-to-build* (list profile))
+                (built-derivations (list profile))
+                (symlink* (derivation->output-path profile) cached)
+                (add-indirect-root* cached)
+                (return (open-inferior cached)))))))))
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 8acfcff8c1..89e92ea2ba 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -28,7 +28,8 @@
   #:use-module ((guix config) #:select (%state-directory))
   #:use-module ((guix utils) #:hide (package-name->name+version))
   #:use-module ((guix build utils)
-                #:select (package-name->name+version))
+                #:select (package-name->name+version mkdir-p))
+  #:use-module (guix i18n)
   #:use-module (guix records)
   #:use-module (guix packages)
   #:use-module (guix derivations)
@@ -127,6 +128,7 @@
             %user-profile-directory
             %profile-directory
             %current-profile
+            ensure-profile-directory
             canonicalize-profile
             user-friendly-profile))
 
@@ -314,12 +316,31 @@ file name."
   "Return a list of manifest entries, one for each item listed in PACKAGES.
 Elements of PACKAGES can be either package objects or package/string tuples
 denoting a specific output of a package."
+  (define inferiors-loaded?
+    ;; This hack allows us to provide seamless integration for inferior
+    ;; packages while not having a hard dependency on (guix inferior).
+    (resolve-module '(guix inferior) #f #f #:ensure #f))
+
+  (define (inferior->entry)
+    (module-ref (resolve-interface '(guix inferior))
+                'inferior-package->manifest-entry))
+
   (manifest
    (map (match-lambda
-         ((package output)
-          (package->manifest-entry package output))
-         ((? package? package)
-          (package->manifest-entry package)))
+          ((package output)
+           (package->manifest-entry package output))
+          ((? package? package)
+           (package->manifest-entry package))
+          ((thing output)
+           (if inferiors-loaded?
+               ((inferior->entry) thing output)
+               (throw 'wrong-type-arg 'packages->manifest
+                      "Wrong package object: ~S" (list thing) (list thing))))
+          (thing
+           (if inferiors-loaded?
+               ((inferior->entry) thing)
+               (throw 'wrong-type-arg 'packages->manifest
+                      "Wrong package object: ~S" (list thing) (list thing)))))
         packages)))
 
 (define (manifest->gexp manifest)
@@ -1230,7 +1251,7 @@ the entries in MANIFEST."
   (define config.scm
     (scheme-file "config.scm"
                  #~(begin
-                     (define-module (guix config)
+                     (define-module #$'(guix config) ;placate Geiser
                        #:export (%libz))
 
                      (define %libz
@@ -1591,28 +1612,73 @@ because the NUMBER is zero.)"
   ;; coexist with Nix profiles.
   (string-append %profile-directory "/guix-profile"))
 
-(define (canonicalize-profile profile)
-  "If PROFILE is %USER-PROFILE-DIRECTORY, return %CURRENT-PROFILE.  Otherwise
-return PROFILE unchanged.  The goal is to treat '-p ~/.guix-profile' as if
-'-p' was omitted."                           ; see <http://bugs.gnu.org/17939>
+(define (ensure-profile-directory)
+  "Attempt to create /…/profiles/per-user/$USER if needed."
+  (let ((s (stat %profile-directory #f)))
+    (unless (and s (eq? 'directory (stat:type s)))
+      (catch 'system-error
+        (lambda ()
+          (mkdir-p %profile-directory))
+        (lambda args
+          ;; Often, we cannot create %PROFILE-DIRECTORY because its
+          ;; parent directory is root-owned and we're running
+          ;; unprivileged.
+          (raise (condition
+                  (&message
+                   (message
+                    (format #f
+                            (G_ "while creating directory `~a': ~a")
+                            %profile-directory
+                            (strerror (system-error-errno args)))))
+                  (&fix-hint
+                   (hint
+                    (format #f (G_ "Please create the @file{~a} directory, \
+with you as the owner.")
+                            %profile-directory))))))))
+
+    ;; Bail out if it's not owned by the user.
+    (unless (or (not s) (= (stat:uid s) (getuid)))
+      (raise (condition
+              (&message
+               (message
+                (format #f (G_ "directory `~a' is not owned by you")
+                        %profile-directory)))
+              (&fix-hint
+               (hint
+                (format #f (G_ "Please change the owner of @file{~a} \
+to user ~s.")
+                        %profile-directory (or (getenv "USER")
+                                               (getenv "LOGNAME")
+                                               (getuid))))))))))
 
-  ;; Trim trailing slashes so that the basename comparison below works as
-  ;; intended.
+(define (canonicalize-profile profile)
+  "If PROFILE points to a profile in %PROFILE-DIRECTORY, return that.
+Otherwise return PROFILE unchanged.  The goal is to treat '-p ~/.guix-profile'
+as if '-p' was omitted."  ; see <http://bugs.gnu.org/17939>
+  ;; Trim trailing slashes so 'readlink' can do its job.
   (let ((profile (string-trim-right profile #\/)))
-    (if (and %user-profile-directory
-             (string=? (canonicalize-path (dirname profile))
-                       (dirname %user-profile-directory))
-             (string=? (basename profile) (basename %user-profile-directory)))
-        %current-profile
-        profile)))
+    (catch 'system-error
+      (lambda ()
+        (let ((target (readlink profile)))
+          (if (string=? (dirname target) %profile-directory)
+              target
+              profile)))
+      (const profile))))
+
+(define %known-shorthand-profiles
+  ;; Known shorthand forms for profiles that the user manipulates.
+  (list (string-append (config-directory #:ensure? #f) "/current")
+        %user-profile-directory))
 
 (define (user-friendly-profile profile)
-  "Return either ~/.guix-profile if that's what PROFILE refers to, directly or
-indirectly, or PROFILE."
-  (if (and %user-profile-directory
-           (false-if-exception
-            (string=? (readlink %user-profile-directory) profile)))
-      %user-profile-directory
+  "Return either ~/.guix-profile or ~/.config/guix/current if that's what
+PROFILE refers to, directly or indirectly, or PROFILE."
+  (or (find (lambda (shorthand)
+              (and shorthand
+                   (let ((target (false-if-exception
+                                  (readlink shorthand))))
+                     (and target (string=? target profile)))))
+            %known-shorthand-profiles)
       profile))
 
 ;;; profiles.scm ends here
diff --git a/guix/progress.scm b/guix/progress.scm
index c9c3cd12a0..9da667a027 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
 
@@ -70,11 +74,11 @@ stopped."
     (($ <progress-reporter> start report stop)
      (start))))
 
-(define (progress-reporter-report! reporter)
+(define (progress-reporter-report! reporter . args)
   "Low-level procedure to lead REPORTER to emit a report."
   (match reporter
     (($ <progress-reporter> start report stop)
-     (report))))
+     (apply report args))))
 
 (define (stop-progress-reporter! reporter)
   "Low-level procedure to stop REPORTER."
@@ -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,37 @@ 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 total 0)                                ;bytes transferred
+
+  (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 ()
+            (set! total 0)
+            (display (format #f "@ download-started ~a ~a ~a~%"
+                             file url (or size "-"))
+                     log-port)))
+   (report (let ((report (rate-limited report-progress %progress-interval)))
+             (lambda (transferred)
+               (set! total transferred)
+               (report transferred))))
+   (stop (lambda ()
+           (let ((size (or size total)))
+             (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.scm b/guix/scripts.scm
index 4cbbbeb96f..98751bc812 100644
--- a/guix/scripts.scm
+++ b/guix/scripts.scm
@@ -26,6 +26,7 @@
   #:use-module (guix monads)
   #:use-module (guix packages)
   #:use-module (guix derivations)
+  #:use-module ((guix profiles) #:select (%profile-directory))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-37)
@@ -169,8 +170,7 @@ Show what and how will/would be built."
 
     (define age
       (match (false-if-not-found
-              (lstat (string-append (config-directory #:ensure? #f)
-                                    "/current")))
+              (lstat (string-append %profile-directory "/current-guix")))
         (#f    #f)
         (stat  (- (time-second (current-time time-utc))
                   (stat:mtime stat)))))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 9d38610633..13978abb77 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,10 @@ 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?)
+                     #:multiplexed-build-output?
+                     (assoc-ref opts 'multiplexed-build-output?)
                      #:verbosity (assoc-ref opts 'verbosity)))
 
 (define set-build-options-from-command-line*
@@ -499,6 +506,8 @@ 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)
+    (multiplexed-build-output? . #t)
     (verbosity . 0)))
 
 (define (show-help)
@@ -617,7 +626,7 @@ must be one of 'package', 'all', or 'transitive'~%")
   "Read the arguments from OPTS and return a list of high-level objects to
 build---packages, gexps, derivations, and so on."
   (define (validate-type x)
-    (unless (or (package? x) (derivation? x) (gexp? x) (procedure? x))
+    (unless (or (derivation? x) (file-like? x) (gexp? x) (procedure? x))
       (leave (G_ "~s: not something we can build~%") x)))
 
   (define (ensure-list x)
@@ -694,6 +703,10 @@ package '~a' has no source~%")
                               (set-guile-for-build (default-guile))
                               (proc))
                             #:system system)))
+                   ((? file-like? obj)
+                    (list (run-with-store store
+                            (lower-object obj system
+                                          #:target (assoc-ref opts 'target)))))
                    ((? gexp? gexp)
                     (list (run-with-store store
                             (mbegin %store-monad
@@ -733,11 +746,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/describe.scm b/guix/scripts/describe.scm
index c1a20fe26c..e59502076c 100644
--- a/guix/scripts/describe.scm
+++ b/guix/scripts/describe.scm
@@ -158,4 +158,4 @@ in the format specified by FMT."
         (#f
          (display-checkout-info format))
         (profile
-         (display-profile-info profile format))))))
+         (display-profile-info (canonicalize-profile profile) format))))))
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 1c04800e42..5965e3426e 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,9 @@ 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)
+    (multiplexed-build-output? . #t)
     (verbosity . 0)))
 
 (define (tag-package-arg opts arg)
@@ -661,59 +665,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/import/cran.scm b/guix/scripts/import/cran.scm
index 30ae6d4342..794fb710cd 100644
--- a/guix/scripts/import/cran.scm
+++ b/guix/scripts/import/cran.scm
@@ -47,6 +47,8 @@ Import and convert the CRAN package for PACKAGE-NAME.\n"))
   (display (G_ "
   -h, --help             display this help and exit"))
   (display (G_ "
+  -r, --recursive        import packages recursively"))
+  (display (G_ "
   -V, --version          display version information and exit"))
   (newline)
   (show-bug-report-information))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 28462d9b8d..13aa8923cd 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)
@@ -197,8 +198,11 @@ added to the pack."
             (with-directory-excursion %root
               (exit
                (zero? (apply system* "tar"
-                             "-I"
-                             (string-join '#+(compressor-command compressor))
+                             #+@(if (compressor-command compressor)
+                                    #~("-I"
+                                       (string-join
+                                        '#+(compressor-command compressor)))
+                                    #~())
                              "--format=gnu"
 
                              ;; Avoid non-determinism in the archive.  Use
@@ -538,6 +542,9 @@ please email '~a'~%")
     (substitutes? . #t)
     (build-hook? . #t)
     (graft? . #t)
+    (print-build-trace? . #t)
+    (print-extended-build-trace? . #t)
+    (multiplexed-build-output? . #t)
     (verbosity . 0)
     (symlinks . ())
     (compressor . ,(first %compressors))))
@@ -684,72 +691,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..5d146b8427 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)
@@ -67,50 +68,14 @@
 
 (define (ensure-default-profile)
   "Ensure the default profile symlink and directory exist and are writable."
-
-  (define (rtfm)
-    (format (current-error-port)
-            (G_ "Try \"info '(guix) Invoking guix package'\" for \
-more information.~%"))
-    (exit 1))
+  (ensure-profile-directory)
 
   ;; Create ~/.guix-profile if it doesn't exist yet.
   (when (and %user-profile-directory
              %current-profile
              (not (false-if-exception
                    (lstat %user-profile-directory))))
-    (symlink %current-profile %user-profile-directory))
-
-  (let ((s (stat %profile-directory #f)))
-    ;; Attempt to create /…/profiles/per-user/$USER if needed.
-    (unless (and s (eq? 'directory (stat:type s)))
-      (catch 'system-error
-        (lambda ()
-          (mkdir-p %profile-directory))
-        (lambda args
-          ;; Often, we cannot create %PROFILE-DIRECTORY because its
-          ;; parent directory is root-owned and we're running
-          ;; unprivileged.
-          (format (current-error-port)
-                  (G_ "error: while creating directory `~a': ~a~%")
-                  %profile-directory
-                  (strerror (system-error-errno args)))
-          (format (current-error-port)
-                  (G_ "Please create the `~a' directory, with you as the owner.~%")
-                  %profile-directory)
-          (rtfm))))
-
-    ;; Bail out if it's not owned by the user.
-    (unless (or (not s) (= (stat:uid s) (getuid)))
-      (format (current-error-port)
-              (G_ "error: directory `~a' is not owned by you~%")
-              %profile-directory)
-      (format (current-error-port)
-              (G_ "Please change the owner of `~a' to user ~s.~%")
-              %profile-directory (or (getenv "USER")
-                                     (getenv "LOGNAME")
-                                     (getuid)))
-      (rtfm))))
+    (symlink %current-profile %user-profile-directory)))
 
 (define (delete-generations store profile generations)
   "Delete GENERATIONS from PROFILE.
@@ -330,7 +295,9 @@ 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)
+    (multiplexed-build-output? . #t)))
 
 (define (show-help)
   (display (G_ "Usage: guix package [OPTION]...
@@ -941,15 +908,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 10e1a99e54..188237aa90 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,9 @@
   `((system . ,(%current-system))
     (substitutes? . #t)
     (build-hook? . #t)
+    (print-build-trace? . #t)
+    (print-extended-build-trace? . #t)
+    (multiplexed-build-output? . #t)
     (graft? . #t)
     (verbosity . 0)))
 
@@ -180,9 +184,25 @@ Download and deploy the latest version of Guix.\n"))
 
 (define (honor-x509-certificates store)
   "Use the right X.509 certificates for Git checkouts over HTTPS."
-  (let ((file      (getenv "SSL_CERT_FILE"))
+  ;; On distros such as CentOS 7, /etc/ssl/certs contains only a couple of
+  ;; files (instead of all the certificates) among which "ca-bundle.crt".  On
+  ;; other distros /etc/ssl/certs usually contains the whole set of
+  ;; certificates along with "ca-certificates.crt".  Try to choose the right
+  ;; one.
+  (let ((file      (letrec-syntax ((choose
+                                    (syntax-rules ()
+                                      ((_ file rest ...)
+                                       (let ((f file))
+                                         (if (and f (file-exists? f))
+                                             f
+                                             (choose rest ...))))
+                                      ((_)
+                                       #f))))
+                     (choose (getenv "SSL_CERT_FILE")
+                             "/etc/ssl/certs/ca-certificates.crt"
+                             "/etc/ssl/certs/ca-bundle.crt")))
         (directory (or (getenv "SSL_CERT_DIR") "/etc/ssl/certs")))
-    (if (or (and file (file-exists? file))
+    (if (or file
             (and=> (stat directory #f)
                    (lambda (st)
                      (> (stat:nlink st) 2))))
@@ -208,6 +228,60 @@ Download and deploy the latest version of Guix.\n"))
 
 
 ;;;
+;;; Profile.
+;;;
+
+(define %current-profile
+  ;; The "real" profile under /var/guix.
+  (string-append %profile-directory "/current-guix"))
+
+(define %user-profile-directory
+  ;; The user-friendly name of %CURRENT-PROFILE.
+  (string-append (config-directory #:ensure? #f) "/current"))
+
+(define (migrate-generations profile directory)
+  "Migrate the generations of PROFILE to DIRECTORY."
+  (format (current-error-port)
+          (G_ "Migrating profile generations to '~a'...~%")
+          %profile-directory)
+  (let ((current (generation-number profile)))
+    (for-each (lambda (generation)
+                (let ((source (generation-file-name profile generation))
+                      (target (string-append directory "/current-guix-"
+                                             (number->string generation)
+                                             "-link")))
+                  ;; Note: Don't use 'rename-file' as SOURCE and TARGET might
+                  ;; live on different file systems.
+                  (symlink (readlink source) target)
+                  (delete-file source)))
+              (profile-generations profile))
+    (symlink (string-append "current-guix-"
+                            (number->string current) "-link")
+             (string-append directory "/current-guix"))))
+
+(define (ensure-default-profile)
+  (ensure-profile-directory)
+
+  ;; In 0.15.0+ we'd create ~/.config/guix/current-[0-9]*-link symlinks.  Move
+  ;; them to %PROFILE-DIRECTORY.
+  (unless (string=? %profile-directory
+                    (dirname (canonicalize-profile %user-profile-directory)))
+    (migrate-generations %user-profile-directory %profile-directory))
+
+  ;; Make sure ~/.config/guix/current points to /var/guix/profiles/….
+  (let ((link %user-profile-directory))
+    (unless (equal? (false-if-exception (readlink link))
+                    %current-profile)
+      (catch 'system-error
+        (lambda ()
+          (false-if-exception (delete-file link))
+          (symlink %current-profile link))
+        (lambda args
+          (leave (G_ "while creating symlink '~a': ~a~%")
+                 link (strerror (system-error-errno args))))))))
+
+
+;;;
 ;;; Queries.
 ;;;
 
@@ -322,11 +396,8 @@ and ALIST2 differ, display HEADING upfront."
   (display-new/upgraded-packages (package-alist gen1)
                                  (package-alist gen2)))
 
-(define (process-query opts)
-  "Process any query specified by OPTS."
-  (define profile
-    (string-append (config-directory) "/current"))
-
+(define (process-query opts profile)
+  "Process any query on PROFILE specified by OPTS."
   (match (assoc-ref opts 'query)
     (('list-generations pattern)
      (define (list-generations profile numbers)
@@ -422,45 +493,45 @@ Use '~/.config/guix/channels.scm' instead."))
                                           (list %default-options)))
             (cache    (string-append (cache-directory) "/pull"))
             (channels (channel-list opts))
-            (profile  (or (assoc-ref opts 'profile)
-                          (string-append (config-directory) "/current"))))
-
+            (profile  (or (assoc-ref opts 'profile) %current-profile)))
+       (ensure-default-profile)
        (cond ((assoc-ref opts 'query)
-              (process-query opts))
+              (process-query opts profile))
              ((assoc-ref opts 'dry-run?)
               #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 6d31dfdaa4..eb82224016 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -837,8 +837,17 @@ REPORTER, which should be a <progress-reporter> object."
        (make-custom-binary-input-port "progress-port-proc"
                                       read! #f #f
                                       (lambda ()
-                                        (close-connection port)
-                                        (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
   (syntax-rules ()
@@ -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..f9af38b7c5 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,9 @@ Some ACTIONS support additional ARGS.\n"))
   `((system . ,(%current-system))
     (substitutes? . #t)
     (build-hook? . #t)
+    (print-build-trace? . #t)
+    (print-extended-build-trace? . #t)
+    (multiplexed-build-output? . #t)
     (graft? . #t)
     (verbosity . 0)
     (file-system-type . "ext4")
@@ -1246,9 +1257,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/self.scm b/guix/self.scm
index 733c4a2cc9..3e29c9a42a 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -904,7 +904,11 @@ is not supported."
         version))
 
   (define guile
-    (guile-for-build guile-version))
+    ;; When PULL-VERSION >= 1, produce a self-contained Guix and use Guile 2.2
+    ;; unconditionally.
+    (guile-for-build (if (>= pull-version 1)
+                         "2.2"
+                         guile-version)))
 
   (mbegin %store-monad
     (set-guile-for-build guile)
@@ -913,7 +917,8 @@ is not supported."
                                #:name (string-append "guix-"
                                                      (shorten version))
                                #:pull-version pull-version
-                               #:guile-version guile-version
+                               #:guile-version (if (>= pull-version 1)
+                                                   "2.2" guile-version)
                                #:guile-for-build guile)))
       (if guix
           (lower-object guix)
diff --git a/guix/serialization.scm b/guix/serialization.scm
index 129374f541..87ad7eeec0 100644
--- a/guix/serialization.scm
+++ b/guix/serialization.scm
@@ -301,8 +301,7 @@ result of 'lstat'; exclude entries for which SELECT? does not return true."
                      (filter-map (lambda (base)
                                    (let ((file (string-append directory
                                                               "/" base)))
-                                     (and (not (member base '("." "..")))
-                                          (select? file (lstat file))
+                                     (and (select? file (lstat file))
                                           base)))
                                  basenames))
 
diff --git a/guix/status.scm b/guix/status.scm
new file mode 100644
index 0000000000..ffa9d9e93c
--- /dev/null
+++ b/guix/status.scm
@@ -0,0 +1,605 @@
+;;; 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)
+  #:autoload   (ice-9 rdelim) (read-string)
+  #: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)
+                         (derivation-path->output-path
+                          derivation-path->output-path))
+  "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-path->output-path 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 (multiplexed-output-supported?)
+  "Return true if the daemon supports \"multiplexed output\"--i.e., \"@
+build-log\" traces."
+  (and (current-store-protocol-version)
+       (>= (current-store-protocol-version) #x163)))
+
+(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))))
+
+  (unless print-log?
+    (display "\r" port))                          ;erase the spinner
+  (match event
+    (('build-started drv . _)
+     (format port (info (G_ "building ~a...")) drv)
+     (newline port))
+    (('build-succeeded drv . _)
+     (when (or print-log? (not (extended-build-trace-supported?)))
+       (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 pid line)
+     (if (multiplexed-output-supported?)
+         (if (not pid)
+             (begin
+               ;; LINE comes from the daemon, not from builders.  Let it
+               ;; through.
+               (display line port)
+               (force-output port))
+             (print-log-line line))
+         (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.
+                (display line port)
+                (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 (maybe-utf8->string bv)
+  "Attempt to decode BV as UTF-8 string and return it.  Gracefully handle the
+case where BV does not contain only valid UTF-8."
+  (catch 'decoding-error
+    (lambda ()
+      (utf8->string bv))
+    (lambda _
+      ;; This is the sledgehammer but it's the only safe way we have to
+      ;; properly handle this.  It's expensive but it's rarely needed.
+      (let ((port (open-bytevector-input-port bv)))
+        (set-port-encoding! port "UTF-8")
+        (set-port-conversion-strategy! port 'substitute)
+        (let ((str (read-string port)))
+          (close-port port)
+          str)))))
+
+(define (bytevector-index bv number offset count)
+  "Search for NUMBER in BV starting from OFFSET and reading up to COUNT bytes;
+return the offset where NUMBER first occurs or #f if it could not be found."
+  (let loop ((offset offset)
+             (count count))
+    (cond ((zero? count) #f)
+          ((= (bytevector-u8-ref bv offset) number) offset)
+          (else (loop (+ 1 offset) (- count 1))))))
+
+(define (split-lines str)
+  "Split STR into lines in a way that preserves newline characters."
+  (let loop ((str str)
+             (result '()))
+    (if (string-null? str)
+        (reverse result)
+        (match (string-index str #\newline)
+          (#f
+           (loop "" (cons str result)))
+          (index
+           (loop (string-drop str (+ index 1))
+                 (cons (string-take str (+ index 1)) result)))))))
+
+(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)
+
+  ;; When true, this represents the current state while reading a
+  ;; "@ build-log" trace: the current builder PID, the previously-read
+  ;; bytevectors, and the number of bytes that remain to be read.
+  (define %build-output-pid #f)
+  (define %build-output '())
+  (define %build-output-left #f)
+
+  (define (process-line line)
+    (cond ((string-prefix? "@ " line)
+           (match (string-tokenize (string-drop line 2))
+             (("build-log" (= string->number pid) (= string->number len))
+              (set! %build-output-pid pid)
+              (set! %build-output '())
+              (set! %build-output-left len))
+             (((= string->symbol event-name) args ...)
+              (set! %state
+                (proc (cons event-name args)
+                      %state)))))
+          (else
+           (set! %state (proc (list 'build-log #f line)
+                              %state)))))
+
+  (define (process-build-output pid output)
+    ;; Transform OUTPUT in 'build-log' events or download events as generated
+    ;; by extended build traces.
+    (define (line->event line)
+      (match (and (string-prefix? "@ " line)
+                  (string-tokenize (string-drop line 2)))
+        ((type . args)
+         (if (or (string-prefix? "download-" type)
+                 (string=? "build-remote" type))
+             (cons (string->symbol type) args)
+             `(build-log ,pid ,line)))
+        (_
+         `(build-log ,pid ,line))))
+
+    (let* ((lines  (split-lines output))
+           (events (map line->event lines)))
+      (set! %state (fold proc %state events))))
+
+  (define (bytevector-range bv offset count)
+    (let ((ptr (bytevector->pointer bv offset)))
+      (pointer->bytevector ptr count)))
+
+  (define (write! bv offset count)
+    (if %build-output-pid
+        (let ((keep (min count %build-output-left)))
+          (set! %build-output
+            (let ((bv* (make-bytevector keep)))
+              (bytevector-copy! bv offset bv* 0 keep)
+              (cons bv* %build-output)))
+          (set! %build-output-left
+            (- %build-output-left keep))
+
+          (when (zero? %build-output-left)
+            (process-build-output %build-output-pid
+                                  (string-concatenate-reverse
+                                   (map maybe-utf8->string %build-output))) ;XXX
+            (set! %build-output '())
+            (set! %build-output-pid #f))
+          keep)
+        (match (bytevector-index bv (char->integer #\newline)
+                                 offset count)
+          ((? integer? cr)
+           (let* ((tail (maybe-utf8->string
+                         (bytevector-range bv offset (- cr -1 offset))))
+                  (line (string-concatenate-reverse
+                         (cons tail %fragments))))
+             (process-line line)
+             (set! %fragments '())
+             (- cr -1 offset)))
+          (#f
+           (unless (zero? count)
+             (let ((str (maybe-utf8->string
+                         (bytevector-range bv offset count))))
+               (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")
+  (cond-expand
+    ((and guile-2 (not guile-2.2)) #t)
+    (else (setvbuf port 'line)))
+  (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..b1bdbf3813 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 #x163)
 
 (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,22 @@ 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?
+
+                            ;; When true, the daemon prefixes builder output
+                            ;; with "@ build-log" traces so we can
+                            ;; distinguish it from daemon output, and we can
+                            ;; distinguish each builder's output
+                            ;; (PRINT-BUILD-TRACE must be true as well.)  The
+                            ;; latter is particularly useful when
+                            ;; MAX-BUILD-JOBS > 1.
+                            multiplexed-build-output?
+
                             build-cores
                             (use-substitutes? #t)
 
@@ -725,7 +761,16 @@ 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 multiplexed-build-output?
+                           `(("multiplexed-build-output"
+                              . ,(if multiplexed-build-output? "true" "false")))
+                           '())
+                     ,@(if timeout
                            `(("build-timeout" . ,(number->string timeout)))
                            '())
                      ,@(if max-silent-time
@@ -1064,13 +1109,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 +1720,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/store/database.scm b/guix/store/database.scm
index 0879a95d0b..341276bc30 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -23,6 +23,7 @@
   #:use-module (guix serialization)
   #:use-module (guix store deduplication)
   #:use-module (guix base16)
+  #:use-module (guix progress)
   #:use-module (guix build syscalls)
   #:use-module ((guix build utils)
                 #:select (mkdir-p executable-file?))
@@ -234,7 +235,8 @@ be used internally by the daemon's build hook."
                   #:prefix prefix #:state-directory state-directory
                   #:deduplicate? deduplicate?
                   #:reset-timestamps? reset-timestamps?
-                  #:schema schema))
+                  #:schema schema
+                  #:log-port (%make-void-port "w")))
 
 (define %epoch
   ;; When it all began.
@@ -245,12 +247,14 @@ be used internally by the daemon's build hook."
                          (deduplicate? #t)
                          (reset-timestamps? #t)
                          registration-time
-                         (schema (sql-schema)))
+                         (schema (sql-schema))
+                         (log-port (current-error-port)))
   "Register all of ITEMS, a list of <store-info> records as returned by
 'read-reference-graph', in the database under PREFIX/STATE-DIRECTORY.  ITEMS
 must be in topological order (with leaves first.)  If the database is
 initially empty, apply SCHEMA to initialize it.  REGISTRATION-TIME must be the
-registration time to be recorded in the database; #f means \"now\"."
+registration time to be recorded in the database; #f means \"now\".
+Write a progress report to LOG-PORT."
 
   ;; Priority for options: first what is given, then environment variables,
   ;; then defaults. %state-directory, %store-directory, and
@@ -286,20 +290,32 @@ registration time to be recorded in the database; #f means \"now\"."
     (define real-file-name
       (string-append store-dir "/" (basename (store-info-item item))))
 
-    (let-values (((hash nar-size) (nar-sha256 real-file-name)))
+    ;; When TO-REGISTER is already registered, skip it.  This makes a
+    ;; significant differences when 'register-closures' is called
+    ;; consecutively for overlapping closures such as 'system' and 'bootcfg'.
+    (unless (path-id db to-register)
       (when reset-timestamps?
         (reset-timestamps real-file-name))
-      (sqlite-register db #:path to-register
-                       #:references (store-info-references item)
-                       #:deriver (store-info-deriver item)
-                       #:hash (string-append "sha256:"
-                                             (bytevector->base16-string hash))
-                       #:nar-size nar-size
-                       #:time registration-time)
-      (when deduplicate?
-        (deduplicate real-file-name hash #:store store-dir))))
+      (let-values (((hash nar-size) (nar-sha256 real-file-name)))
+        (sqlite-register db #:path to-register
+                         #:references (store-info-references item)
+                         #:deriver (store-info-deriver item)
+                         #:hash (string-append "sha256:"
+                                               (bytevector->base16-string hash))
+                         #:nar-size nar-size
+                         #:time registration-time)
+        (when deduplicate?
+          (deduplicate real-file-name hash #:store store-dir)))))
 
   (mkdir-p db-dir)
   (parameterize ((sql-schema schema))
     (with-database (string-append db-dir "/db.sqlite") db
-      (for-each (cut register db <>) items))))
+      (let* ((prefix   (format #f "registering ~a items" (length items)))
+             (progress (progress-reporter/bar (length items)
+                                              prefix log-port)))
+        (call-with-progress-reporter progress
+          (lambda (report)
+            (for-each (lambda (item)
+                        (register db item)
+                        (report))
+                      items)))))))
diff --git a/guix/tests.scm b/guix/tests.scm
index 06e9f8da0b..bcf9b990e5 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -17,6 +17,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix tests)
+  #:use-module ((guix config) #:select (%storedir %localstatedir))
   #:use-module (guix store)
   #:use-module (guix derivations)
   #:use-module (guix packages)
@@ -30,6 +31,7 @@
   #:use-module (ice-9 binary-ports)
   #:use-module (web uri)
   #:export (open-connection-for-tests
+            with-external-store
             random-text
             random-bytevector
             file=?
@@ -74,6 +76,39 @@
 
       store)))
 
+(define (call-with-external-store proc)
+  "Call PROC with an open connection to the external store or #f it there is
+no external store to talk to."
+  (parameterize ((%daemon-socket-uri
+                  (string-append %localstatedir
+                                 "/guix/daemon-socket/socket"))
+                 (%store-prefix %storedir))
+    (define store
+      (catch #t
+        (lambda ()
+          (open-connection))
+        (const #f)))
+
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        ;; Since we're using a different store we must clear the
+        ;; package-derivation cache.
+        (hash-clear! (@@ (guix packages) %derivation-cache))
+
+        (proc store))
+      (lambda ()
+        (when store
+          (close-connection store))))))
+
+(define-syntax-rule (with-external-store store exp ...)
+  "Evaluate EXP with STORE bound to the external store rather than the
+temporary test store, or #f if there is no external store to talk to.
+
+This is meant to be used for tests that need to build packages that would be
+too expensive to build entirely in the test store."
+  (call-with-external-store (lambda (store) exp ...)))
+
 (define (random-seed)
   (or (and=> (getenv "GUIX_TESTS_RANDOM_SEED")
              number->string)
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