gnu: linux-initrd: Factorize boot code.
* guix/build/linux-initrd.scm (boot-system): New procedure. * gnu/system/linux-initrd.scm (qemu-initrd): Add keyword parameters 'guile-modules-in-chroot?' and 'mounts'. Change builder to simply call 'boot-system'. (gnu-system-initrd): Change to a simple call to 'qemu-initrd'. * gnu/system/vm.scm (expression->derivation-in-linux-vm): Call 'qemu-initrd' with #:guile-modules-in-chroot?.
This commit is contained in:
Ludovic Courtès
parent
735c6dd7fa
commit
d425471182
|
|
@ -19,6 +19,8 @@
|
||||||
(define-module (gnu system linux-initrd)
|
(define-module (gnu system linux-initrd)
|
||||||
#:use-module (guix monads)
|
#:use-module (guix monads)
|
||||||
#:use-module (guix utils)
|
#:use-module (guix utils)
|
||||||
|
#:use-module ((guix store)
|
||||||
|
#:select (%store-prefix))
|
||||||
#:use-module (gnu packages cpio)
|
#:use-module (gnu packages cpio)
|
||||||
#:use-module (gnu packages compression)
|
#:use-module (gnu packages compression)
|
||||||
#:use-module (gnu packages linux)
|
#:use-module (gnu packages linux)
|
||||||
|
|
@ -181,180 +183,46 @@ list of Guile module names to be embedded in the initrd."
|
||||||
#:modules '((guix build utils))
|
#:modules '((guix build utils))
|
||||||
#:inputs inputs)))
|
#:inputs inputs)))
|
||||||
|
|
||||||
(define (qemu-initrd)
|
(define* (qemu-initrd #:key
|
||||||
|
guile-modules-in-chroot?
|
||||||
|
(mounts `((cifs "/store" ,(%store-prefix))
|
||||||
|
(cifs "/xchg" "/xchg"))))
|
||||||
"Return a monadic derivation that builds an initrd for use in a QEMU guest
|
"Return a monadic derivation that builds an initrd for use in a QEMU guest
|
||||||
where the store is shared with the host."
|
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:
|
||||||
|
|
||||||
|
(FILE-SYSTEM-TYPE SOURCE TARGET)
|
||||||
|
|
||||||
|
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!)."
|
||||||
|
(define cifs-modules
|
||||||
|
;; Modules needed to mount CIFS file systems.
|
||||||
|
'("md4.ko" "ecb.ko" "cifs.ko"))
|
||||||
|
|
||||||
|
(define linux-modules
|
||||||
|
;; Modules added to the initrd and loaded from the initrd.
|
||||||
|
(if (assoc-ref mounts 'cifs)
|
||||||
|
cifs-modules
|
||||||
|
'()))
|
||||||
|
|
||||||
(expression->initrd
|
(expression->initrd
|
||||||
'(begin
|
`(begin
|
||||||
(use-modules (srfi srfi-1)
|
(use-modules (guix build linux-initrd))
|
||||||
(srfi srfi-26)
|
|
||||||
(ice-9 match)
|
|
||||||
((system base compile) #:select (compile-file))
|
|
||||||
(guix build utils)
|
|
||||||
(guix build linux-initrd))
|
|
||||||
|
|
||||||
(display "Welcome, this is GNU's early boot Guile.\n")
|
(boot-system #:mounts ',mounts
|
||||||
(display "Use '--repl' for an initrd REPL.\n\n")
|
#:linux-modules ',linux-modules
|
||||||
|
#:qemu-guest-networking? #t
|
||||||
(mount-essential-file-systems)
|
#:guile-modules-in-chroot? ',guile-modules-in-chroot?))
|
||||||
(let* ((args (linux-command-line))
|
|
||||||
(option (lambda (opt)
|
|
||||||
(let ((opt (string-append opt "=")))
|
|
||||||
(and=> (find (cut string-prefix? opt <>)
|
|
||||||
args)
|
|
||||||
(lambda (arg)
|
|
||||||
(substring arg (+ 1 (string-index arg #\=))))))))
|
|
||||||
(to-load (option "--load"))
|
|
||||||
(root (option "--root")))
|
|
||||||
|
|
||||||
(when (member "--repl" args)
|
|
||||||
((@ (system repl repl) start-repl)))
|
|
||||||
|
|
||||||
(display "loading CIFS and companion modules...\n")
|
|
||||||
(for-each (compose load-linux-module*
|
|
||||||
(cut string-append "/modules/" <>))
|
|
||||||
(list "md4.ko" "ecb.ko" "cifs.ko"))
|
|
||||||
|
|
||||||
(unless (configure-qemu-networking)
|
|
||||||
(display "network interface is DOWN\n"))
|
|
||||||
|
|
||||||
;; Make /dev nodes.
|
|
||||||
(make-essential-device-nodes)
|
|
||||||
|
|
||||||
;; Prepare the real root file system under /root.
|
|
||||||
(unless (file-exists? "/root")
|
|
||||||
(mkdir "/root"))
|
|
||||||
(if root
|
|
||||||
(mount root "/root" "ext3")
|
|
||||||
(mount "none" "/root" "tmpfs"))
|
|
||||||
(mount-essential-file-systems #:root "/root")
|
|
||||||
|
|
||||||
(mkdir-p "/root/xchg")
|
|
||||||
(mkdir-p "/root/nix/store")
|
|
||||||
|
|
||||||
(unless (file-exists? "/root/dev")
|
|
||||||
(mkdir "/root/dev")
|
|
||||||
(make-essential-device-nodes #:root "/root"))
|
|
||||||
|
|
||||||
;; Mount the host's store and exchange directory.
|
|
||||||
(mount-qemu-smb-share "/store" "/root/nix/store")
|
|
||||||
(mount-qemu-smb-share "/xchg" "/root/xchg")
|
|
||||||
|
|
||||||
;; Copy the directories that contain .scm and .go files so that the
|
|
||||||
;; child process in the chroot can load modules (we would bind-mount
|
|
||||||
;; them but for some reason that fails with EINVAL -- XXX).
|
|
||||||
(mkdir-p "/root/share")
|
|
||||||
(mkdir-p "/root/lib")
|
|
||||||
(mount "none" "/root/share" "tmpfs")
|
|
||||||
(mount "none" "/root/lib" "tmpfs")
|
|
||||||
(copy-recursively "/share" "/root/share"
|
|
||||||
#:log (%make-void-port "w"))
|
|
||||||
(copy-recursively "/lib" "/root/lib"
|
|
||||||
#:log (%make-void-port "w"))
|
|
||||||
|
|
||||||
|
|
||||||
(if to-load
|
|
||||||
(letrec ((resolve
|
|
||||||
(lambda (file)
|
|
||||||
;; If FILE is a symlink to an absolute file name,
|
|
||||||
;; resolve it as if we were under /root.
|
|
||||||
(let ((st (lstat file)))
|
|
||||||
(if (eq? 'symlink (stat:type st))
|
|
||||||
(let ((target (readlink file)))
|
|
||||||
(resolve (string-append "/root" target)))
|
|
||||||
file)))))
|
|
||||||
(format #t "loading boot file '~a'...\n" to-load)
|
|
||||||
(compile-file (resolve (string-append "/root/" to-load))
|
|
||||||
#:output-file "/root/loader.go"
|
|
||||||
#:opts %auto-compilation-options)
|
|
||||||
(match (primitive-fork)
|
|
||||||
(0
|
|
||||||
(chroot "/root")
|
|
||||||
(load-compiled "/loader.go")
|
|
||||||
|
|
||||||
;; TODO: Remove /lib, /share, and /loader.go.
|
|
||||||
)
|
|
||||||
(pid
|
|
||||||
(format #t "boot file loaded under PID ~a~%" pid)
|
|
||||||
(let ((status (waitpid pid)))
|
|
||||||
(reboot)))))
|
|
||||||
(begin
|
|
||||||
(display "no boot file passed via '--load'\n")
|
|
||||||
(display "entering a warm and cozy REPL\n")
|
|
||||||
((@ (system repl repl) start-repl))))))
|
|
||||||
#:name "qemu-initrd"
|
#:name "qemu-initrd"
|
||||||
#:modules '((guix build utils)
|
#:modules '((guix build utils)
|
||||||
(guix build linux-initrd))
|
(guix build linux-initrd))
|
||||||
#:linux linux-libre
|
#:linux linux-libre
|
||||||
#:linux-modules '("cifs.ko" "md4.ko" "ecb.ko")))
|
#:linux-modules linux-modules))
|
||||||
|
|
||||||
(define (gnu-system-initrd)
|
(define (gnu-system-initrd)
|
||||||
"Initrd for the GNU system itself, with nothing QEMU-specific."
|
"Initrd for the GNU system itself, with nothing QEMU-specific."
|
||||||
(expression->initrd
|
(qemu-initrd #:guile-modules-in-chroot? #f))
|
||||||
'(begin
|
|
||||||
(use-modules (srfi srfi-1)
|
|
||||||
(srfi srfi-26)
|
|
||||||
(ice-9 match)
|
|
||||||
(guix build utils)
|
|
||||||
(guix build linux-initrd))
|
|
||||||
|
|
||||||
(display "Welcome, this is GNU's early boot Guile.\n")
|
|
||||||
(display "Use '--repl' for an initrd REPL.\n\n")
|
|
||||||
|
|
||||||
(mount-essential-file-systems)
|
|
||||||
(let* ((args (linux-command-line))
|
|
||||||
(option (lambda (opt)
|
|
||||||
(let ((opt (string-append opt "=")))
|
|
||||||
(and=> (find (cut string-prefix? opt <>)
|
|
||||||
args)
|
|
||||||
(lambda (arg)
|
|
||||||
(substring arg (+ 1 (string-index arg #\=))))))))
|
|
||||||
(to-load (option "--load"))
|
|
||||||
(root (option "--root")))
|
|
||||||
|
|
||||||
(when (member "--repl" args)
|
|
||||||
((@ (system repl repl) start-repl)))
|
|
||||||
|
|
||||||
;; Make /dev nodes.
|
|
||||||
(make-essential-device-nodes)
|
|
||||||
|
|
||||||
;; Prepare the real root file system under /root.
|
|
||||||
(mkdir-p "/root")
|
|
||||||
(if root
|
|
||||||
;; Assume ROOT has a usable /dev tree.
|
|
||||||
(mount root "/root" "ext3")
|
|
||||||
(begin
|
|
||||||
(mount "none" "/root" "tmpfs")
|
|
||||||
(make-essential-device-nodes #:root "/root")))
|
|
||||||
|
|
||||||
(mount-essential-file-systems #:root "/root")
|
|
||||||
|
|
||||||
(mkdir-p "/root/tmp")
|
|
||||||
(mount "none" "/root/tmp" "tmpfs")
|
|
||||||
|
|
||||||
;; XXX: We don't copy our fellow Guile modules to /root (see
|
|
||||||
;; 'qemu-initrd'), so if TO-LOAD tries to load a module (which can
|
|
||||||
;; happen if it throws, to display the exception!), then we're
|
|
||||||
;; screwed. Hopefully TO-LOAD is a simple expression that just does
|
|
||||||
;; '(execlp ...)'.
|
|
||||||
|
|
||||||
(if to-load
|
|
||||||
(begin
|
|
||||||
(format #t "loading '~a'...\n" to-load)
|
|
||||||
(chroot "/root")
|
|
||||||
(primitive-load to-load)
|
|
||||||
(format (current-error-port)
|
|
||||||
"boot program '~a' terminated, rebooting~%"
|
|
||||||
to-load)
|
|
||||||
(sleep 2)
|
|
||||||
(reboot))
|
|
||||||
(begin
|
|
||||||
(display "no init file passed via '--load'\n")
|
|
||||||
(display "entering a warm and cozy REPL\n")
|
|
||||||
((@ (system repl repl) start-repl))))))
|
|
||||||
#:name "qemu-system-initrd"
|
|
||||||
#:modules '((guix build linux-initrd)
|
|
||||||
(guix build utils))
|
|
||||||
#:linux linux-libre))
|
|
||||||
|
|
||||||
;;; linux-initrd.scm ends here
|
;;; linux-initrd.scm ends here
|
||||||
|
|
|
||||||
|
|
@ -178,9 +178,9 @@ made available under the /xchg CIFS share."
|
||||||
(user-builder (text-file "builder-in-linux-vm"
|
(user-builder (text-file "builder-in-linux-vm"
|
||||||
(object->string exp*)))
|
(object->string exp*)))
|
||||||
(coreutils -> (car (assoc-ref %final-inputs "coreutils")))
|
(coreutils -> (car (assoc-ref %final-inputs "coreutils")))
|
||||||
(initrd (if initrd
|
(initrd (if initrd ; use the default initrd?
|
||||||
(return initrd)
|
(return initrd)
|
||||||
(qemu-initrd))) ; default initrd
|
(qemu-initrd #:guile-modules-in-chroot? #t)))
|
||||||
(inputs (lower-inputs `(("qemu" ,qemu)
|
(inputs (lower-inputs `(("qemu" ,qemu)
|
||||||
("linux" ,linux)
|
("linux" ,linux)
|
||||||
("initrd" ,initrd)
|
("initrd" ,initrd)
|
||||||
|
|
|
||||||
|
|
@ -19,6 +19,12 @@
|
||||||
(define-module (guix build linux-initrd)
|
(define-module (guix build linux-initrd)
|
||||||
#:use-module (rnrs io ports)
|
#:use-module (rnrs io ports)
|
||||||
#:use-module (system foreign)
|
#:use-module (system foreign)
|
||||||
|
#:autoload (system repl repl) (start-repl)
|
||||||
|
#:autoload (system base compile) (compile-file)
|
||||||
|
#:use-module (srfi srfi-1)
|
||||||
|
#:use-module (srfi srfi-26)
|
||||||
|
#:use-module (ice-9 match)
|
||||||
|
#:use-module (guix build utils)
|
||||||
#:export (mount-essential-file-systems
|
#:export (mount-essential-file-systems
|
||||||
linux-command-line
|
linux-command-line
|
||||||
make-essential-device-nodes
|
make-essential-device-nodes
|
||||||
|
|
@ -26,7 +32,8 @@
|
||||||
mount-qemu-smb-share
|
mount-qemu-smb-share
|
||||||
bind-mount
|
bind-mount
|
||||||
load-linux-module*
|
load-linux-module*
|
||||||
device-number))
|
device-number
|
||||||
|
boot-system))
|
||||||
|
|
||||||
;;; Commentary:
|
;;; Commentary:
|
||||||
;;;
|
;;;
|
||||||
|
|
@ -151,4 +158,116 @@ Vanilla QEMU's `-smb' option just exports a /qemu share, whereas our
|
||||||
the last argument of `mknod'."
|
the last argument of `mknod'."
|
||||||
(+ (* major 256) minor))
|
(+ (* major 256) minor))
|
||||||
|
|
||||||
|
(define* (boot-system #:key
|
||||||
|
(linux-modules '())
|
||||||
|
qemu-guest-networking?
|
||||||
|
guile-modules-in-chroot?
|
||||||
|
(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
|
||||||
|
QEMU-GUEST-NETWORKING? is true, mounting the file systems specified in MOUNTS,
|
||||||
|
and finally booting into the new root if any. The initrd supports kernel
|
||||||
|
command-line options '--load', '--root', and '--repl'.
|
||||||
|
|
||||||
|
MOUNTS must be a list of elements of the form:
|
||||||
|
|
||||||
|
(FILE-SYSTEM-TYPE SOURCE TARGET)
|
||||||
|
|
||||||
|
When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in
|
||||||
|
the new root."
|
||||||
|
(define (resolve file)
|
||||||
|
;; If FILE is a symlink to an absolute file name, resolve it as if we were
|
||||||
|
;; under /root.
|
||||||
|
(let ((st (lstat file)))
|
||||||
|
(if (eq? 'symlink (stat:type st))
|
||||||
|
(let ((target (readlink file)))
|
||||||
|
(resolve (string-append "/root" target)))
|
||||||
|
file)))
|
||||||
|
|
||||||
|
(display "Welcome, this is GNU's early boot Guile.\n")
|
||||||
|
(display "Use '--repl' for an initrd REPL.\n\n")
|
||||||
|
|
||||||
|
(mount-essential-file-systems)
|
||||||
|
(let* ((args (linux-command-line))
|
||||||
|
(option (lambda (opt)
|
||||||
|
(let ((opt (string-append opt "=")))
|
||||||
|
(and=> (find (cut string-prefix? opt <>)
|
||||||
|
args)
|
||||||
|
(lambda (arg)
|
||||||
|
(substring arg (+ 1 (string-index arg #\=))))))))
|
||||||
|
(to-load (option "--load"))
|
||||||
|
(root (option "--root")))
|
||||||
|
|
||||||
|
(when (member "--repl" args)
|
||||||
|
(start-repl))
|
||||||
|
|
||||||
|
(display "loading kernel modules...\n")
|
||||||
|
(for-each (compose load-linux-module*
|
||||||
|
(cut string-append "/modules/" <>))
|
||||||
|
linux-modules)
|
||||||
|
|
||||||
|
(when qemu-guest-networking?
|
||||||
|
(unless (configure-qemu-networking)
|
||||||
|
(display "network interface is DOWN\n")))
|
||||||
|
|
||||||
|
;; Make /dev nodes.
|
||||||
|
(make-essential-device-nodes)
|
||||||
|
|
||||||
|
;; Prepare the real root file system under /root.
|
||||||
|
(unless (file-exists? "/root")
|
||||||
|
(mkdir "/root"))
|
||||||
|
(if root
|
||||||
|
(mount root "/root" "ext3")
|
||||||
|
(mount "none" "/root" "tmpfs"))
|
||||||
|
(mount-essential-file-systems #:root "/root")
|
||||||
|
|
||||||
|
(unless (file-exists? "/root/dev")
|
||||||
|
(mkdir "/root/dev")
|
||||||
|
(make-essential-device-nodes #:root "/root"))
|
||||||
|
|
||||||
|
;; Mount the specified file systems.
|
||||||
|
(for-each (match-lambda
|
||||||
|
(('cifs source target)
|
||||||
|
(let ((target (string-append "/root/" target)))
|
||||||
|
(mkdir-p target)
|
||||||
|
(mount-qemu-smb-share source target)))
|
||||||
|
;; TODO: Add 9p.
|
||||||
|
)
|
||||||
|
mounts)
|
||||||
|
|
||||||
|
(when guile-modules-in-chroot?
|
||||||
|
;; Copy the directories that contain .scm and .go files so that the
|
||||||
|
;; child process in the chroot can load modules (we would bind-mount
|
||||||
|
;; them but for some reason that fails with EINVAL -- XXX).
|
||||||
|
(mkdir-p "/root/share")
|
||||||
|
(mkdir-p "/root/lib")
|
||||||
|
(mount "none" "/root/share" "tmpfs")
|
||||||
|
(mount "none" "/root/lib" "tmpfs")
|
||||||
|
(copy-recursively "/share" "/root/share"
|
||||||
|
#:log (%make-void-port "w"))
|
||||||
|
(copy-recursively "/lib" "/root/lib"
|
||||||
|
#:log (%make-void-port "w")))
|
||||||
|
|
||||||
|
(if to-load
|
||||||
|
(begin
|
||||||
|
(format #t "loading '~a'...\n" to-load)
|
||||||
|
(chroot "/root")
|
||||||
|
;; TODO: Remove /lib, /share, and /loader.go.
|
||||||
|
(catch #t
|
||||||
|
(lambda ()
|
||||||
|
(primitive-load to-load))
|
||||||
|
(lambda args
|
||||||
|
(format (current-error-port) "'~a' raised an exception: ~s~%"
|
||||||
|
to-load args)
|
||||||
|
(start-repl)))
|
||||||
|
(format (current-error-port)
|
||||||
|
"boot program '~a' terminated, rebooting~%"
|
||||||
|
to-load)
|
||||||
|
(sleep 2)
|
||||||
|
(reboot))
|
||||||
|
(begin
|
||||||
|
(display "no boot file passed via '--load'\n")
|
||||||
|
(display "entering a warm and cozy REPL\n")
|
||||||
|
(start-repl)))))
|
||||||
|
|
||||||
;;; linux-initrd.scm ends here
|
;;; linux-initrd.scm ends here
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue