diff options
| -rw-r--r-- | gnu/packages/linux-initrd.scm | 66 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 61 |
2 files changed, 104 insertions, 23 deletions
diff --git a/gnu/packages/linux-initrd.scm b/gnu/packages/linux-initrd.scm index ab8787f02c..6dd2a10e53 100644 --- a/gnu/packages/linux-initrd.scm +++ b/gnu/packages/linux-initrd.scm @@ -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 diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 596a697738..86430ea168 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -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))))) |