Merge branch 'master' into core-updates

3 files changed, 90 insertions, 74 deletions

diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index 9e30c0d23e..5a5e703872 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.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>
 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -18,6 +18,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu build install)
+  #:use-module (guix store database)
   #:use-module (guix build utils)
   #:use-module (guix build store-copy)
   #:use-module (srfi srfi-26)
@@ -25,7 +26,6 @@
   #:export (install-boot-config
             evaluate-populate-directive
             populate-root-file-system
-            reset-timestamps
             register-closure
             populate-single-profile-directory))
 
@@ -110,9 +110,6 @@ STORE."
 
     ("/var/guix/gcroots/booted-system" -> "/run/booted-system")
     ("/var/guix/gcroots/current-system" -> "/run/current-system")
-
-    ;; XXX: 'guix-register' creates this symlink with a wrong target, so
-    ;; create it upfront to be sure.
     ("/var/guix/gcroots/profiles" -> "/var/guix/profiles")
 
     (directory "/bin")
@@ -144,37 +141,27 @@ includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM."
                 (try))
               (apply throw args)))))))
 
-(define (reset-timestamps directory)
-  "Reset the timestamps of all the files under DIRECTORY, so that they appear
-as created and modified at the Epoch."
-  (display "clearing file timestamps...\n")
-  (for-each (lambda (file)
-              (let ((s (lstat file)))
-                ;; XXX: Guile uses libc's 'utime' function (not 'futime'), so
-                ;; the timestamp of symlinks cannot be changed, and there are
-                ;; symlinks here pointing to /gnu/store, which is the host,
-                ;; read-only store.
-                (unless (eq? (stat:type s) 'symlink)
-                  (utime file 0 0 0 0))))
-            (find-files directory #:directories? #t)))
-
-(define* (register-closure store closure
-                           #:key (deduplicate? #t))
-  "Register CLOSURE in STORE, where STORE is the directory name of the target
-store and CLOSURE is the name of a file containing a reference graph as used
-by 'guix-register'.  As a side effect, this resets timestamps on store files
-and, if DEDUPLICATE? is true, deduplicates files common to CLOSURE and the
-rest of STORE."
-  (let ((status (apply system* "guix-register" "--prefix" store
-                       (append (if deduplicate? '() '("--no-deduplication"))
-                               (list closure)))))
-    (unless (zero? status)
-      (error "failed to register store items" closure))))
+(define* (register-closure prefix closure
+                           #:key
+                           (deduplicate? #t) (reset-timestamps? #t)
+                           (schema (sql-schema)))
+  "Register CLOSURE in PREFIX, where PREFIX is the directory name of the
+target store and CLOSURE is the name of a file containing a reference graph as
+produced by #:references-graphs..  As a side effect, if RESET-TIMESTAMPS? is
+true, reset timestamps on store files and, if DEDUPLICATE? is true,
+deduplicates files common to CLOSURE and the rest of PREFIX."
+  (let ((items (call-with-input-file closure read-reference-graph)))
+    (register-items items
+                    #:prefix prefix
+                    #:deduplicate? deduplicate?
+                    #:reset-timestamps? reset-timestamps?
+                    #:registration-time %epoch
+                    #:schema schema)))
 
 (define* (populate-single-profile-directory directory
                                             #:key profile closure
                                             deduplicate?
-                                            register?)
+                                            register? schema)
   "Populate DIRECTORY with a store containing PROFILE, whose closure is given
 in the file called CLOSURE (as generated by #:references-graphs.)  DIRECTORY
 is initialized to contain a single profile under /root pointing to PROFILE.
@@ -200,11 +187,11 @@ This is used to create the self-contained tarballs with 'guix pack'."
 
   (when register?
     (register-closure (canonicalize-path directory) closure
-                      #:deduplicate? deduplicate?)
+                      #:deduplicate? deduplicate?
+                      #:schema schema)
 
-    ;; XXX: 'guix-register' registers profiles as GC roots but the symlink
-    ;; target uses $TMPDIR.  Fix that.
-    (delete-file (scope "/var/guix/gcroots/profiles"))
+    (mkdir-p* "/var/guix/profiles")
+    (mkdir-p* "/var/guix/gcroots")
     (symlink* "/var/guix/profiles"
               "/var/guix/gcroots/profiles"))
 
diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm
index 87d2e98edf..2ee2f1771f 100644
--- a/gnu/build/linux-modules.scm
+++ b/gnu/build/linux-modules.scm
@@ -32,6 +32,7 @@
             ensure-dot-ko
             module-aliases
             module-dependencies
+            normalize-module-name
             recursive-module-dependencies
             modules-loaded
             module-loaded?
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index fa3ce7790d..abecc8c470 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -25,6 +25,7 @@
   #:use-module (guix build utils)
   #:use-module (guix build store-copy)
   #:use-module (guix build syscalls)
+  #:use-module ((guix store database) #:select (reset-timestamps))
   #:use-module (gnu build linux-boot)
   #:use-module (gnu build install)
   #:use-module (gnu system uuid)
@@ -33,6 +34,7 @@
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
+  #:use-module (ice-9 popen)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
@@ -345,7 +347,7 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
     ;; Optionally, register the inputs in the image's store.
     (when register-closures?
       (unless copy-closures?
-        ;; XXX: 'guix-register' wants to palpate the things it registers, so
+        ;; XXX: 'register-closure' wants to palpate the things it registers, so
         ;; bind-mount the store on the target.
         (mkdir-p target-store)
         (mount (%store-directory) target-store "" MS_BIND))
@@ -354,6 +356,7 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
       (for-each (lambda (closure)
                   (register-closure target
                                     (string-append "/xchg/" closure)
+                                    #:reset-timestamps? copy-closures?
                                     #:deduplicate? deduplicate?))
                 closures)
       (unless copy-closures?
@@ -363,7 +366,7 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
     (display "populating...\n")
     (populate-root-file-system system-directory target)
 
-    ;; 'guix-register' resets timestamps and everything, so no need to do it
+    ;; 'register-closure' resets timestamps and everything, so no need to do it
     ;; once more in that case.
     (unless register-closures?
       (reset-timestamps target))))
@@ -406,42 +409,67 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
                              register-closures? (closures '()))
   "Given a GRUB package, creates an iso image as TARGET, using CONFIG-FILE as
 GRUB configuration and OS-DRV as the stuff in it."
-  (let ((grub-mkrescue (string-append grub "/bin/grub-mkrescue"))
-        (target-store  (string-append "/tmp/root" (%store-directory))))
-    (populate-root-file-system os-drv "/tmp/root")
-
-    (mount (%store-directory) target-store "" MS_BIND)
-
-    (when register-closures?
-      (display "registering closures...\n")
-      (for-each (lambda (closure)
-                  (register-closure
-                   "/tmp/root"
-                   (string-append "/xchg/" closure)
-                   ;; XXX: Using deduplication causes cross device link errors.
-                   #:deduplicate? #f))
-                closures))
-
-    (apply invoke
-           `(,grub-mkrescue "-o" ,target
-                            ,(string-append "boot/grub/grub.cfg=" config-file)
-                            ,(string-append "gnu/store=" os-drv "/..")
-                            "etc=/tmp/root/etc"
-                            "var=/tmp/root/var"
-                            "run=/tmp/root/run"
-                            ;; /mnt is used as part of the installation
-                            ;; process, as the mount point for the target
-                            ;; file system, so create it.
-                            "mnt=/tmp/root/mnt"
-                            "--"
-                            "-volid" ,(string-upcase volume-id)
-                            ,@(if volume-uuid
-                                  `("-volume_date" "uuid"
-                                    ,(string-filter (lambda (value)
-                                                      (not (char=? #\- value)))
-                                                    (iso9660-uuid->string
-                                                     volume-uuid)))
-                                  `())))))
+  (define grub-mkrescue
+    (string-append grub "/bin/grub-mkrescue"))
+
+  (define target-store
+    (string-append "/tmp/root" (%store-directory)))
+
+  (define items
+    ;; The store items to add to the image.
+    (delete-duplicates
+     (append-map (lambda (closure)
+                   (map store-info-item
+                        (call-with-input-file (string-append "/xchg/" closure)
+                          read-reference-graph)))
+                 closures)))
+
+  (populate-root-file-system os-drv "/tmp/root")
+  (mount (%store-directory) target-store "" MS_BIND)
+
+  (when register-closures?
+    (display "registering closures...\n")
+    (for-each (lambda (closure)
+                (register-closure
+                 "/tmp/root"
+                 (string-append "/xchg/" closure)
+
+                 ;; TARGET-STORE is a read-only bind-mount so we shouldn't try
+                 ;; to modify it.
+                 #:deduplicate? #f
+                 #:reset-timestamps? #f))
+              closures)
+    (register-bootcfg-root "/tmp/root" config-file))
+
+  (let ((pipe
+         (apply open-pipe* OPEN_WRITE
+                grub-mkrescue "-o" target
+                (string-append "boot/grub/grub.cfg=" config-file)
+                "etc=/tmp/root/etc"
+                "var=/tmp/root/var"
+                "run=/tmp/root/run"
+                ;; /mnt is used as part of the installation
+                ;; process, as the mount point for the target
+                ;; file system, so create it.
+                "mnt=/tmp/root/mnt"
+                "-path-list" "-"
+                "--"
+                "-volid" (string-upcase volume-id)
+                (if volume-uuid
+                    `("-volume_date" "uuid"
+                      ,(string-filter (lambda (value)
+                                        (not (char=? #\- value)))
+                                      (iso9660-uuid->string
+                                       volume-uuid)))
+                    `()))))
+    ;; Pass lines like 'gnu/store/…-x=/gnu/store/…-x' corresponding to the
+    ;; '-path-list -' option.
+    (for-each (lambda (item)
+                (format pipe "~a=~a~%"
+                        (string-drop item 1) item))
+              items)
+    (unless (zero? (close-pipe pipe))
+      (error "oh, my! grub-mkrescue failed" grub-mkrescue))))
 
 (define* (initialize-hard-disk device
                                #:key