Merge branch 'master' into core-updates

11 files changed, 466 insertions, 58 deletions

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/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/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..669ebe04e5 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -314,12 +314,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)
diff --git a/guix/progress.scm b/guix/progress.scm
index c9c3cd12a0..53aea1c56d 100644
--- a/guix/progress.scm
+++ b/guix/progress.scm
@@ -70,11 +70,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."
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 10e1a99e54..39aebb18e2 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -180,9 +180,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))))
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 6d31dfdaa4..50c6a22064 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -837,8 +837,8 @@ REPORTER, which should be a <progress-reporter> object."
        (make-custom-binary-input-port "progress-port-proc"
                                       read! #f #f
                                       (lambda ()
-                                        (close-connection port)
-                                        (stop)))))))
+                                        (stop)
+                                        (close-port port)))))))
 
 (define-syntax with-networking
   (syntax-rules ()
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/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)))))))