Merge branch 'master' into core-updates

1 files changed, 191 insertions, 156 deletions

diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index 42ca29cb58..b80ff10f1e 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -18,19 +18,24 @@
 
 (define-module (gnu system linux-initrd)
   #:use-module (guix monads)
+  #:use-module (guix gexp)
   #:use-module (guix utils)
   #:use-module ((guix store)
                 #:select (%store-prefix))
+  #:use-module ((guix derivations)
+                #:select (derivation->output-path))
   #:use-module (gnu packages cpio)
   #:use-module (gnu packages compression)
   #:use-module (gnu packages linux)
   #:use-module (gnu packages guile)
   #:use-module ((gnu packages make-bootstrap)
                 #:select (%guile-static-stripped))
+  #:use-module (gnu system file-systems)
+  #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
+  #:use-module (srfi srfi-1)
   #:export (expression->initrd
-            qemu-initrd
-            gnu-system-initrd))
+            qemu-initrd))
 
 
 ;;; Commentary:
@@ -49,12 +54,14 @@
                              (name "guile-initrd")
                              (system (%current-system))
                              (modules '())
+                             (to-copy '())
                              (linux #f)
                              (linux-modules '()))
   "Return a package that contains a Linux initrd (a gzipped cpio archive)
 containing GUILE and that evaluates EXP upon booting.  LINUX-MODULES is a list
-of `.ko' file names to be copied from LINUX into the initrd.  MODULES is a
-list of Guile module names to be embedded in the initrd."
+of `.ko' file names to be copied from LINUX into the initrd.  TO-COPY is a
+list of additional derivations or packages to copy to the initrd.  MODULES is
+a list of Guile module names to be embedded in the initrd."
 
   ;; General Linux overview in `Documentation/early-userspace/README' and
   ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'.
@@ -63,150 +70,157 @@ list of Guile module names to be embedded in the initrd."
     ;; Return a regexp that matches STR exactly.
     (string-append "^" (regexp-quote str) "$"))
 
-  (define builder
-    `(begin
-       (use-modules (guix build utils)
-                    (ice-9 pretty-print)
-                    (ice-9 popen)
-                    (ice-9 match)
-                    (ice-9 ftw)
-                    (srfi srfi-26)
-                    (system base compile)
-                    (rnrs bytevectors)
-                    ((system foreign) #:select (sizeof)))
-
-       (let ((guile   (assoc-ref %build-inputs "guile"))
-             (cpio    (string-append (assoc-ref %build-inputs "cpio")
-                                     "/bin/cpio"))
-             (gzip    (string-append (assoc-ref %build-inputs "gzip")
-                                     "/bin/gzip"))
-             (modules (assoc-ref %build-inputs "modules"))
-             (gos     (assoc-ref %build-inputs "modules/compiled"))
-             (scm-dir (string-append "share/guile/" (effective-version)))
-             (go-dir  (format #f ".cache/guile/ccache/~a-~a-~a-~a"
-                              (effective-version)
-                              (if (eq? (native-endianness) (endianness little))
-                                  "LE"
-                                  "BE")
-                              (sizeof '*)
-                              (effective-version)))
-             (out     (assoc-ref %outputs "out")))
-         (mkdir out)
-         (mkdir "contents")
-         (with-directory-excursion "contents"
-           (copy-recursively guile ".")
-           (call-with-output-file "init"
-             (lambda (p)
-               (format p "#!/bin/guile -ds~%!#~%" guile)
-               (pretty-print ',exp p)))
-           (chmod "init" #o555)
-           (chmod "bin/guile" #o555)
-
-           ;; Copy Guile modules.
-           (chmod scm-dir #o777)
-           (copy-recursively modules scm-dir
-                             #:follow-symlinks? #t)
-           (copy-recursively gos (string-append "lib/guile/"
-                                                (effective-version) "/ccache")
-                             #:follow-symlinks? #t)
-
-           ;; Compile `init'.
-           (mkdir-p go-dir)
-           (set! %load-path (cons modules %load-path))
-           (set! %load-compiled-path (cons gos %load-compiled-path))
-           (compile-file "init"
-                         #:opts %auto-compilation-options
-                         #:output-file (string-append go-dir "/init.go"))
-
-           ;; Copy Linux modules.
-           (let* ((linux      (assoc-ref %build-inputs "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))
-
-           ;; 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 out "/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 out
-                    (and (zero? (system* gzip "--best" "initrd"))
-                         (rename-file "initrd.gz" "initrd")))))))))
-
-  (mlet* %store-monad
-      ((source   (imported-modules modules))
-       (compiled (compiled-modules modules))
-       (inputs   (lower-inputs
-                  `(("guile" ,guile)
-                    ("cpio" ,cpio)
-                    ("gzip" ,gzip)
-                    ("modules" ,source)
-                    ("modules/compiled" ,compiled)
-                    ,@(if linux
-                          `(("linux" ,linux))
-                          '())))))
-   (derivation-expression name builder
-                          #:modules '((guix build utils))
-                          #:inputs inputs)))
-
-(define* (qemu-initrd #:key
+  (mlet* %store-monad ((source   (imported-modules modules))
+                       (compiled (compiled-modules modules)))
+    (define builder
+      ;; TODO: Move most of this code to (guix build linux-initrd).
+      #~(begin
+          (use-modules (guix build utils)
+                       (ice-9 pretty-print)
+                       (ice-9 popen)
+                       (ice-9 match)
+                       (ice-9 ftw)
+                       (srfi srfi-26)
+                       (system base compile)
+                       (rnrs bytevectors)
+                       ((system foreign) #:select (sizeof)))
+
+          (let ((cpio    (string-append #$cpio "/bin/cpio"))
+                (gzip    (string-append #$gzip "/bin/gzip"))
+                (modules #$source)
+                (gos     #$compiled)
+                (scm-dir (string-append "share/guile/" (effective-version)))
+                (go-dir  (format #f ".cache/guile/ccache/~a-~a-~a-~a"
+                                 (effective-version)
+                                 (if (eq? (native-endianness) (endianness little))
+                                     "LE"
+                                     "BE")
+                                 (sizeof '*)
+                                 (effective-version))))
+            (mkdir #$output)
+            (mkdir "contents")
+            (with-directory-excursion "contents"
+              (copy-recursively #$guile ".")
+              (call-with-output-file "init"
+                (lambda (p)
+                  (format p "#!/bin/guile -ds~%!#~%" #$guile)
+                  (pretty-print '#$exp p)))
+              (chmod "init" #o555)
+              (chmod "bin/guile" #o555)
+
+              ;; Copy Guile modules.
+              (chmod scm-dir #o777)
+              (copy-recursively modules scm-dir
+                                #:follow-symlinks? #t)
+              (copy-recursively gos (string-append "lib/guile/"
+                                                   (effective-version) "/ccache")
+                                #:follow-symlinks? #t)
+
+              ;; Compile `init'.
+              (mkdir-p go-dir)
+              (set! %load-path (cons modules %load-path))
+              (set! %load-compiled-path (cons gos %load-compiled-path))
+              (compile-file "init"
+                            #:opts %auto-compilation-options
+                            #: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))
+
+              ;; 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")))))))))
+
+   (gexp->derivation name builder
+                     #:modules '((guix build utils)))))
+
+(define (file-system->spec fs)
+  "Return a list corresponding to file-system FS that can be passed to the
+initrd code."
+  (match fs
+    (($ <file-system> device mount-point type flags options _ check?)
+     (list device mount-point type flags options check?))))
+
+(define* (qemu-initrd file-systems
+                      #:key
                       guile-modules-in-chroot?
-                      volatile-root?
-                      (mounts `((cifs "/store" ,(%store-prefix))
-                                (cifs "/xchg" "/xchg"))))
+                      (qemu-networking? #t)
+                      volatile-root?)
   "Return a monadic derivation that builds an initrd for use in a QEMU guest
-where the store is shared with the host.  MOUNTS is a list of file systems to
-be mounted atop the root file system, where each item has the form:
+where the store is shared with the host.  FILE-SYSTEMS is a list of
+file-systems to be mounted by the initrd, possibly in addition to the root
+file system specified on the kernel command line via '--root'.
 
-    (FILE-SYSTEM-TYPE SOURCE TARGET)
+When QEMU-NETWORKING? is true, set up networking with the standard QEMU
+parameters.
+
+When VOLATILE-ROOT? is true, the root file system is writable but any changes
+to it are lost.
 
 When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in
 the new root.  This is necessary is the file specified as '--load' needs
 access to these modules (which is the case if it wants to even just print an
-exception and backtrace!).
-
-When VOLATILE-ROOT? is true, the root file system is writable but any changes
-to it are lost."
+exception and backtrace!)."
   (define cifs-modules
     ;; Modules needed to mount CIFS file systems.
     '("md4.ko" "ecb.ko" "cifs.ko"))
@@ -215,35 +229,56 @@ to it are lost."
     ;; Modules for the 9p paravirtualized file system.
     '("9pnet.ko" "9p.ko" "9pnet_virtio.ko"))
 
+  (define (file-system-type-predicate type)
+    (lambda (fs)
+      (string=? (file-system-type fs) type)))
+
   (define linux-modules
     ;; Modules added to the initrd and loaded from the initrd.
     `("virtio.ko" "virtio_ring.ko" "virtio_pci.ko"
       "virtio_balloon.ko" "virtio_blk.ko" "virtio_net.ko"
-      ,@(if (assoc-ref mounts 'cifs)
+      ,@(if (find (file-system-type-predicate "cifs") file-systems)
             cifs-modules
             '())
-      ,@(if (assoc-ref mounts '9p)
+      ,@(if (find (file-system-type-predicate "9p") file-systems)
             virtio-9p-modules
+            '())
+      ,@(if volatile-root?
+            '("fuse.ko")
+            '())))
+
+  (define helper-packages
+    ;; Packages to be copied on the initrd.
+    `(,@(if (find (lambda (fs)
+                    (string-prefix? "ext" (file-system-type fs)))
+                  file-systems)
+            (list e2fsck/static)
+            '())
+      ,@(if volatile-root?
+            (list unionfs-fuse/static)
             '())))
 
   (expression->initrd
-   `(begin
-      (use-modules (guix build linux-initrd))
-
-      (boot-system #:mounts ',mounts
-                   #:linux-modules ',linux-modules
-                   #:qemu-guest-networking? #t
-                   #:guile-modules-in-chroot? ',guile-modules-in-chroot?
-                   #:volatile-root? ',volatile-root?))
+   #~(begin
+       (use-modules (guix build linux-initrd)
+                    (guix build utils)
+                    (srfi srfi-26))
+
+       (with-output-to-port (%make-void-port "w")
+         (lambda ()
+           (set-path-environment-variable "PATH" '("bin" "sbin")
+                                          '#$helper-packages)))
+
+       (boot-system #:mounts '#$(map file-system->spec file-systems)
+                    #:linux-modules '#$linux-modules
+                    #:qemu-guest-networking? #$qemu-networking?
+                    #:guile-modules-in-chroot? '#$guile-modules-in-chroot?
+                    #:volatile-root? '#$volatile-root?))
    #:name "qemu-initrd"
    #:modules '((guix build utils)
                (guix build linux-initrd))
+   #:to-copy helper-packages
    #:linux linux-libre
    #:linux-modules linux-modules))
 
-(define (gnu-system-initrd)
-  "Initrd for the GNU system itself, with nothing QEMU-specific."
-  (qemu-initrd #:guile-modules-in-chroot? #f
-               #:mounts '()))
-
 ;;; linux-initrd.scm ends here