Merge branch 'master' into core-updates

2 files changed, 111 insertions, 121 deletions

diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index e48b399a9d..627d17bac2 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -68,16 +68,22 @@ initrd."
   ;; General Linux overview in `Documentation/early-userspace/README' and
   ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'.
 
-  (define (string->regexp str)
-    ;; Return a regexp that matches STR exactly.
-    (string-append "^" (regexp-quote str) "$"))
-
-  (mlet* %store-monad ((source   (imported-modules modules))
-                       (compiled (compiled-modules modules)))
+  (define graph-files
+    (unfold-right zero?
+                  number->string
+                  1-
+                  (length to-copy)))
+
+  (mlet %store-monad ((source     (imported-modules modules))
+                      (compiled   (compiled-modules modules))
+                      (module-dir (flat-linux-module-directory linux
+                                                               linux-modules)))
     (define builder
-      ;; TODO: Move most of this code to (guix build linux-initrd).
+      ;; TODO: Move most of this code to (gnu build linux-initrd).
       #~(begin
-          (use-modules (guix build utils)
+          (use-modules (gnu build linux-initrd)
+                       (guix build utils)
+                       (guix build store-copy)
                        (ice-9 pretty-print)
                        (ice-9 popen)
                        (ice-9 match)
@@ -87,9 +93,7 @@ initrd."
                        (rnrs bytevectors)
                        ((system foreign) #:select (sizeof)))
 
-          (let ((cpio    (string-append #$cpio "/bin/cpio"))
-                (gzip    (string-append #$gzip "/bin/gzip"))
-                (modules #$source)
+          (let ((modules #$source)
                 (gos     #$compiled)
                 (scm-dir (string-append "share/guile/" (effective-version)))
                 (go-dir  (format #f ".cache/guile/ccache/~a-~a-~a-~a"
@@ -101,6 +105,7 @@ initrd."
                                  (effective-version))))
             (mkdir #$output)
             (mkdir "contents")
+
             (with-directory-excursion "contents"
               (copy-recursively #$guile ".")
               (call-with-output-file "init"
@@ -127,74 +132,58 @@ initrd."
                             #:output-file (string-append go-dir "/init.go"))
 
               ;; Copy Linux modules.
-              (let* ((linux      #$linux)
-                     (module-dir (and linux
-                                      (string-append linux "/lib/modules"))))
-                (mkdir "modules")
-                #$@(map (lambda (module)
-                          #~(match (find-files module-dir
-                                               #$(string->regexp module))
-                              ((file)
-                               (format #t "copying '~a'...~%" file)
-                               (copy-file file (string-append "modules/"
-                                                              #$module)))
-                              (()
-                               (error "module not found" #$module module-dir))
-                              ((_ ...)
-                               (error "several modules by that name"
-                                      #$module module-dir))))
-                        linux-modules))
-
-              (let ((store   #$(string-append "." (%store-prefix)))
-                    (to-copy '#$to-copy))
-                (unless (null? to-copy)
-                  (mkdir-p store))
-                ;; XXX: Should we do export-references-graph?
-                (for-each (lambda (input)
-                            (let ((target
-                                   (string-append store "/"
-                                                  (basename input))))
-                              (copy-recursively input target)))
-                          to-copy))
+              (mkdir "modules")
+              (copy-recursively #$module-dir "modules")
+
+              ;; Populate the initrd's store.
+              (with-directory-excursion ".."
+                (populate-store '#$graph-files "contents"))
 
               ;; Reset the timestamps of all the files that will make it in the
               ;; initrd.
               (for-each (cut utime <> 0 0 0 0)
                         (find-files "." ".*"))
 
-              (system* cpio "--version")
-              (let ((pipe (open-pipe* OPEN_WRITE cpio "-o"
-                                      "-O" (string-append #$output "/initrd")
-                                      "-H" "newc" "--null")))
-                (define print0
-                  (let ((len (string-length "./")))
-                    (lambda (file)
-                      (format pipe "~a\0" (string-drop file len)))))
-
-                ;; Note: as per `ramfs-rootfs-initramfs.txt', always add
-                ;; directory entries before the files that are inside of it: "The
-                ;; Linux kernel cpio extractor won't create files in a directory
-                ;; that doesn't exist, so the directory entries must go before
-                ;; the files that go in those directories."
-                (file-system-fold (const #t)
-                                  (lambda (file stat result) ; leaf
-                                    (print0 file))
-                                  (lambda (dir stat result) ; down
-                                    (unless (string=? dir ".")
-                                      (print0 dir)))
-                                  (const #f)         ; up
-                                  (const #f)         ; skip
-                                  (const #f)
-                                  #f
-                                  ".")
-
-                (and (zero? (close-pipe pipe))
-                     (with-directory-excursion #$output
-                       (and (zero? (system* gzip "--best" "initrd"))
-                            (rename-file "initrd.gz" "initrd")))))))))
+              (write-cpio-archive (string-append #$output "/initrd") "."
+                                  #:cpio (string-append #$cpio "/bin/cpio")
+                                  #:gzip (string-append #$gzip "/bin/gzip"))))))
 
    (gexp->derivation name builder
-                     #:modules '((guix build utils)))))
+                     #:modules '((guix build utils)
+                                 (guix build store-copy)
+                                 (gnu build linux-initrd))
+                     #:references-graphs (zip graph-files to-copy))))
+
+(define (flat-linux-module-directory linux modules)
+  "Return a flat directory containing the Linux kernel modules listed in
+MODULES and taken from LINUX."
+  (define build-exp
+    #~(begin
+        (use-modules (ice-9 match) (ice-9 regex)
+                     (guix build utils))
+
+        (define (string->regexp str)
+          ;; Return a regexp that matches STR exactly.
+          (string-append "^" (regexp-quote str) "$"))
+
+        (define module-dir
+          (string-append #$linux "/lib/modules"))
+
+        (mkdir #$output)
+        (for-each (lambda (module)
+                    (match (find-files module-dir (string->regexp module))
+                      ((file)
+                       (format #t "copying '~a'...~%" file)
+                       (copy-file file (string-append #$output "/" module)))
+                      (()
+                       (error "module not found" module module-dir))
+                      ((_ ...)
+                       (error "several modules by that name"
+                              module module-dir))))
+                  '#$modules)))
+
+  (gexp->derivation "linux-modules" build-exp
+                    #:modules '((guix build utils))))
 
 (define (file-system->spec fs)
   "Return a list corresponding to file-system FS that can be passed to the
@@ -277,7 +266,7 @@ exception and backtrace!)."
 
   (expression->initrd
    #~(begin
-       (use-modules (guix build linux-initrd)
+       (use-modules (gnu build linux-boot)
                     (guix build utils)
                     (srfi srfi-26))
 
@@ -293,7 +282,8 @@ exception and backtrace!)."
                     #:volatile-root? '#$volatile-root?))
    #:name "base-initrd"
    #:modules '((guix build utils)
-               (guix build linux-initrd))
+               (gnu build linux-boot)
+               (gnu build file-systems))
    #:to-copy helper-packages
    #:linux linux-libre
    #:linux-modules linux-modules))
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 42fc23ee8f..205bf2cb19 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -23,7 +23,7 @@
   #:use-module (guix derivations)
   #:use-module (guix packages)
   #:use-module (guix monads)
-  #:use-module ((guix build vm)
+  #:use-module ((gnu build vm)
                 #:select (qemu-command))
   #:use-module (gnu packages base)
   #:use-module (gnu packages guile)
@@ -112,10 +112,12 @@ input tuple.  The output file name is when building for SYSTEM."
                                              (qemu qemu-headless)
                                              (env-vars '())
                                              (modules
-                                              '((guix build vm)
-                                                (guix build install)
-                                                (guix build linux-initrd)
-                                                (guix build utils)))
+                                              '((gnu build vm)
+                                                (gnu build install)
+                                                (gnu build linux-boot)
+                                                (gnu build file-systems)
+                                                (guix build utils)
+                                                (guix build store-copy)))
                                              (guile-for-build
                                               (%guile-for-build))
 
@@ -164,7 +166,7 @@ made available under the /xchg CIFS share."
       ;; Code that launches the VM that evaluates EXP.
       #~(begin
           (use-modules (guix build utils)
-                       (guix build vm))
+                       (gnu build vm))
 
           (let ((inputs  '#$(list qemu coreutils))
                 (linux   (string-append #$linux "/bzImage"))
@@ -217,48 +219,46 @@ INPUTS is a list of inputs (as for packages).  When COPY-INPUTS? is true, copy
 all of INPUTS into the image being built.  When REGISTER-CLOSURES? is true,
 register INPUTS in the store database of the image so that Guix can be used in
 the image."
-  (mlet %store-monad
-      ((graph (sequence %store-monad (map input->name+output inputs))))
-   (expression->derivation-in-linux-vm
-    name
-    #~(begin
-        (use-modules (guix build vm)
-                     (guix build utils))
-
-        (let ((inputs
-               '#$(append (list qemu parted grub e2fsprogs util-linux)
-                          (map canonical-package
-                               (list sed grep coreutils findutils gawk))
-                          (if register-closures? (list guix) '())))
-
-              ;; This variable is unused but allows us to add INPUTS-TO-COPY
-              ;; as inputs.
-              (to-register
-                '#$(map (match-lambda
-                         ((name thing) thing)
-                         ((name thing output) `(,thing ,output)))
-                        inputs)))
-
-          (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
-
-          (let ((graphs '#$(match inputs
-                             (((names . _) ...)
-                              names))))
-            (initialize-hard-disk "/dev/vda"
-                                  #:system-directory #$os-derivation
-                                  #:grub.cfg #$grub-configuration
-                                  #:closures graphs
-                                  #:copy-closures? #$copy-inputs?
-                                  #:register-closures? #$register-closures?
-                                  #:disk-image-size #$disk-image-size
-                                  #:file-system-type #$file-system-type
-                                  #:file-system-label #$file-system-label)
-            (reboot))))
-    #:system system
-    #:make-disk-image? #t
-    #:disk-image-size disk-image-size
-    #:disk-image-format disk-image-format
-    #:references-graphs graph)))
+  (expression->derivation-in-linux-vm
+   name
+   #~(begin
+       (use-modules (gnu build vm)
+                    (guix build utils))
+
+       (let ((inputs
+              '#$(append (list qemu parted grub e2fsprogs util-linux)
+                         (map canonical-package
+                              (list sed grep coreutils findutils gawk))
+                         (if register-closures? (list guix) '())))
+
+             ;; This variable is unused but allows us to add INPUTS-TO-COPY
+             ;; as inputs.
+             (to-register
+              '#$(map (match-lambda
+                       ((name thing) thing)
+                       ((name thing output) `(,thing ,output)))
+                      inputs)))
+
+         (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+
+         (let ((graphs '#$(match inputs
+                            (((names . _) ...)
+                             names))))
+           (initialize-hard-disk "/dev/vda"
+                                 #:system-directory #$os-derivation
+                                 #:grub.cfg #$grub-configuration
+                                 #:closures graphs
+                                 #:copy-closures? #$copy-inputs?
+                                 #:register-closures? #$register-closures?
+                                 #:disk-image-size #$disk-image-size
+                                 #:file-system-type #$file-system-type
+                                 #:file-system-label #$file-system-label)
+           (reboot))))
+   #:system system
+   #:make-disk-image? #t
+   #:disk-image-size disk-image-size
+   #:disk-image-format disk-image-format
+   #:references-graphs inputs))
 
 
 ;;;