diff options
| -rw-r--r-- | gnu/system/linux-initrd.scm | 75 | ||||
| -rw-r--r-- | guix/build/linux-initrd.scm | 38 |
2 files changed, 73 insertions, 40 deletions
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 42ca29cb58..786e068764 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -21,12 +21,15 @@ #: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 (ice-9 match) #:use-module (ice-9 regex) #:export (expression->initrd qemu-initrd @@ -49,12 +52,14 @@ (name "guile-initrd") (system (%current-system)) (modules '()) + (inputs '()) (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. INPUTS is a list +of additional inputs to be copied in 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,7 +68,16 @@ 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 + (define (files-to-copy) + (mlet %store-monad ((inputs (lower-inputs inputs))) + (return (map (match-lambda + ((_ drv) + (derivation->output-path drv)) + ((_ drv sub-drv) + (derivation->output-path drv sub-drv))) + inputs)))) + + (define (builder to-copy) `(begin (use-modules (guix build utils) (ice-9 pretty-print) @@ -137,6 +151,18 @@ list of Guile module names to be embedded in the initrd." ,module module-dir)))) linux-modules)) + ,@(if (null? to-copy) + '() + `((let ((store ,(string-append "." (%store-prefix)))) + (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) @@ -184,8 +210,10 @@ list of Guile module names to be embedded in the initrd." ("modules/compiled" ,compiled) ,@(if linux `(("linux" ,linux)) - '()))))) - (derivation-expression name builder + '()) + ,@inputs))) + (to-copy (files-to-copy))) + (derivation-expression name (builder to-copy) #:modules '((guix build utils)) #:inputs inputs))) @@ -224,22 +252,31 @@ to it are lost." '()) ,@(if (assoc-ref mounts '9p) virtio-9p-modules + '()) + ,@(if volatile-root? + '("fuse.ko") '()))) - (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?)) - #:name "qemu-initrd" - #:modules '((guix build utils) - (guix build linux-initrd)) - #:linux linux-libre - #:linux-modules linux-modules)) + (mlet %store-monad + ((unionfs (package-file unionfs-fuse/static "bin/unionfs"))) + (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? + #:unionfs ,unionfs + #:volatile-root? ',volatile-root?)) + #:name "qemu-initrd" + #:modules '((guix build utils) + (guix build linux-initrd)) + #:linux linux-libre + #:linux-modules linux-modules + #:inputs (if volatile-root? + `(("unionfs" ,unionfs-fuse/static)) + '())))) (define (gnu-system-initrd) "Initrd for the GNU system itself, with nothing QEMU-specific." diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 61d4304b65..5d4446e720 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -143,7 +143,10 @@ (symlink "/proc/self/fd" (scope "dev/fd")) (symlink "/proc/self/fd/0" (scope "dev/stdin")) (symlink "/proc/self/fd/1" (scope "dev/stdout")) - (symlink "/proc/self/fd/2" (scope "dev/stderr"))) + (symlink "/proc/self/fd/2" (scope "dev/stderr")) + + ;; File systems in user space (FUSE). + (mknod (scope "dev/fuse") 'char-special #o666 (device-number 10 229))) (define %host-qemu-ipv4-address (inet-pton AF_INET "10.0.2.10")) @@ -212,7 +215,7 @@ the last argument of `mknod'." (linux-modules '()) qemu-guest-networking? guile-modules-in-chroot? - volatile-root? + volatile-root? unionfs (mounts '())) "This procedure is meant to be called from an initrd. Boot a system by first loading LINUX-MODULES, then setting up QEMU guest networking if @@ -277,27 +280,20 @@ to it are lost." (lambda () (if volatile-root? (begin - ;; XXX: For lack of a union file system... (mkdir-p "/real-root") (mount root "/real-root" "ext3" MS_RDONLY) - (mount "none" "/root" "tmpfs") - - ;; XXX: 'copy-recursively' cannot deal with device nodes, so - ;; explicitly avoid /dev. - (for-each (lambda (file) - (unless (string=? "dev" file) - (copy-recursively (string-append "/real-root/" - file) - (string-append "/root/" - file) - #:log (%make-void-port - "w")))) - (scandir "/real-root" - (lambda (file) - (not (member file '("." "..")))))) - - ;; TODO: Unmount /real-root. - ) + (mkdir-p "/rw-root") + (mount "none" "/rw-root" "tmpfs") + + ;; We want read-write /dev nodes. + (make-essential-device-nodes #:root "/rw-root") + + ;; Make /root a union of the tmpfs and the actual root. + (unless (zero? (system* unionfs "-o" + "cow,allow_other,use_ino,dev" + "/rw-root=RW:/real-root=RO" + "/root")) + (error "unionfs failed"))) (mount root "/root" "ext3"))) (lambda args (format (current-error-port) "exception while mounting '~a': ~s~%" |