gnu: vm: First stab at building a populated QEMU image.
* gnu/packages/linux-initrd.scm (gnu-system-initrd): New variable. * gnu/system/vm.scm (qemu-image): Add #:linux-arguments parameter. [input->name+derivation]: Add case for 'store-path?' items. Remove LOADER from `inputs'.
This commit is contained in:
Ludovic Courtès
parent
29804e6eb2
commit
1b89a66e1b
|
|
@ -332,4 +332,70 @@ the Linux kernel.")
|
|||
#:linux linux-libre
|
||||
#:linux-modules '("cifs.ko" "md4.ko" "ecb.ko")))
|
||||
|
||||
(define-public gnu-system-initrd
|
||||
;; Initrd for the GNU system itself, with nothing QEMU-specific.
|
||||
(expression->initrd
|
||||
'(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.
|
||||
(unless (file-exists? "/root")
|
||||
(mkdir "/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")
|
||||
|
||||
;; 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~%")
|
||||
(sleep 2)
|
||||
(reboot))
|
||||
(begin
|
||||
(display "no init file passed via '--exec'\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
|
||||
|
|
|
|||
|
|
@ -21,7 +21,11 @@
|
|||
#:use-module (guix store)
|
||||
#:use-module (guix derivations)
|
||||
#:use-module (guix packages)
|
||||
#:use-module ((gnu packages base) #:select (%final-inputs guile-final))
|
||||
#:use-module ((gnu packages base) #:select (%final-inputs
|
||||
guile-final
|
||||
coreutils))
|
||||
#:use-module (gnu packages guile)
|
||||
#:use-module (gnu packages bash)
|
||||
#:use-module (gnu packages qemu)
|
||||
#:use-module (gnu packages parted)
|
||||
#:use-module (gnu packages grub)
|
||||
|
|
@ -30,7 +34,7 @@
|
|||
#:use-module ((gnu packages make-bootstrap)
|
||||
#:select (%guile-static-stripped))
|
||||
#:use-module ((gnu packages system)
|
||||
#:select (shadow))
|
||||
#:select (mingetty))
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (ice-9 match)
|
||||
|
|
@ -177,11 +181,14 @@ made available under the /xchg CIFS share."
|
|||
(system (%current-system))
|
||||
(disk-image-size (* 100 (expt 2 20)))
|
||||
(linux linux-libre)
|
||||
(linux-arguments '())
|
||||
(initrd qemu-initrd)
|
||||
(inputs '())
|
||||
(inputs-to-copy '())
|
||||
(boot-expression #f))
|
||||
"Return a bootable, stand-alone QEMU image.
|
||||
"Return a bootable, stand-alone QEMU image. The returned image is a full
|
||||
disk image, with a GRUB installation whose default entry boots LINUX, with the
|
||||
arguments LINUX-ARGUMENTS, and using INITRD as its initial RAM disk.
|
||||
|
||||
INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied
|
||||
into the image being built.
|
||||
|
|
@ -197,13 +204,9 @@ process."
|
|||
((name (? package? package) sub-drv)
|
||||
`(,name . ,(derivation-path->output-path
|
||||
(package-derivation store package system)
|
||||
sub-drv)))))
|
||||
|
||||
(define loader
|
||||
(and boot-expression
|
||||
(add-text-to-store store "loader"
|
||||
(object->string boot-expression)
|
||||
'())))
|
||||
sub-drv)))
|
||||
((input (and (? string?) (? store-path?) file))
|
||||
`(,input . ,file))))
|
||||
|
||||
(expression->derivation-in-linux-vm
|
||||
store "qemu-image"
|
||||
|
|
@ -299,12 +302,10 @@ set timeout=5
|
|||
search.file /boot/bzImage
|
||||
|
||||
menuentry \"Boot-to-Guile! (GNU System technology preview)\" {
|
||||
linux /boot/bzImage --root=/dev/vda1 ~a
|
||||
linux /boot/bzImage ~a
|
||||
initrd /boot/initrd
|
||||
}"
|
||||
,(if loader
|
||||
(string-append "--load=" loader)
|
||||
""))))
|
||||
,(string-join linux-arguments))))
|
||||
(and (zero?
|
||||
(system* grub "--no-floppy"
|
||||
"--boot-directory" "/fs/boot"
|
||||
|
|
@ -319,10 +320,6 @@ menuentry \"Boot-to-Guile! (GNU System technology preview)\" {
|
|||
("linux" ,linux-libre)
|
||||
("initrd" ,initrd)
|
||||
|
||||
,@(if loader
|
||||
`(("loader" ,loader))
|
||||
'())
|
||||
|
||||
;; For shell scripts.
|
||||
("sed" ,(car (assoc-ref %final-inputs "sed")))
|
||||
("grep" ,(car (assoc-ref %final-inputs "grep")))
|
||||
|
|
@ -367,13 +364,31 @@ menuentry \"Boot-to-Guile! (GNU System technology preview)\" {
|
|||
(set! store (open-connection)))
|
||||
(lambda ()
|
||||
(parameterize ((%guile-for-build (package-derivation store guile-final)))
|
||||
(let* ((drv (package-derivation store shadow))
|
||||
(login (string-append (derivation-path->output-path drv)
|
||||
"/bin/login")))
|
||||
(let* ((out (derivation-path->output-path
|
||||
(package-derivation store mingetty)))
|
||||
(getty (string-append out "/sbin/mingetty"))
|
||||
(boot (add-text-to-store store "boot"
|
||||
(object->string
|
||||
`(begin
|
||||
;; Become the session leader,
|
||||
;; so that mingetty can do
|
||||
;; 'TIOCSCTTY'.
|
||||
(setsid)
|
||||
|
||||
;; Directly into mingetty.
|
||||
(execl ,getty "mingetty"
|
||||
"--noclear" "tty1")))
|
||||
(list out))))
|
||||
(qemu-image store
|
||||
#:boot-expression `(execl ,login "login" "tty1")
|
||||
#:initrd gnu-system-initrd
|
||||
#:linux-arguments `("--root=/dev/vda1"
|
||||
,(string-append "--load=" boot))
|
||||
#:disk-image-size (* 400 (expt 2 20))
|
||||
#:inputs-to-copy `(("shadow" ,shadow))))))
|
||||
#:inputs-to-copy `(("boot" ,boot)
|
||||
("coreutils" ,coreutils)
|
||||
("bash" ,bash)
|
||||
("guile" ,guile-2.0)
|
||||
("mingetty" ,mingetty))))))
|
||||
(lambda ()
|
||||
(close-connection store)))))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue