diff options
Diffstat (limited to 'guix/build/linux-initrd.scm')
| -rw-r--r-- | guix/build/linux-initrd.scm | 197 |
1 files changed, 192 insertions, 5 deletions
diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index ae18a16e11..80ce679496 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -19,14 +19,23 @@ (define-module (guix build linux-initrd) #:use-module (rnrs io ports) #: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 (ice-9 ftw) + #:use-module (guix build utils) #:export (mount-essential-file-systems linux-command-line make-essential-device-nodes configure-qemu-networking mount-qemu-smb-share + mount-qemu-9p bind-mount load-linux-module* - device-number)) + device-number + boot-system)) ;;; Commentary: ;;; @@ -74,10 +83,26 @@ (unless (file-exists? (scope "dev")) (mkdir (scope "dev"))) - ;; Make the device nodes for QEMU's hard disk and partitions. - (mknod (scope "dev/vda") 'block-special #o644 (device-number 8 0)) - (mknod (scope "dev/vda1") 'block-special #o644 (device-number 8 1)) - (mknod (scope "dev/vda2") 'block-special #o644 (device-number 8 2)) + ;; Make the device nodes for SCSI disks. + (mknod (scope "dev/sda") 'block-special #o644 (device-number 8 0)) + (mknod (scope "dev/sda1") 'block-special #o644 (device-number 8 1)) + (mknod (scope "dev/sda2") 'block-special #o644 (device-number 8 2)) + + ;; The virtio (para-virtualized) block devices, as supported by QEMU/KVM. + (mknod (scope "dev/vda") 'block-special #o644 (device-number 252 0)) + (mknod (scope "dev/vda1") 'block-special #o644 (device-number 252 1)) + (mknod (scope "dev/vda2") 'block-special #o644 (device-number 252 2)) + + ;; Memory (used by Xorg's VESA driver.) + (mknod (scope "dev/mem") 'char-special #o640 (device-number 1 1)) + (mknod (scope "dev/kmem") 'char-special #o640 (device-number 1 2)) + + ;; Inputs (used by Xorg.) + (unless (file-exists? (scope "dev/input")) + (mkdir (scope "dev/input"))) + (mknod (scope "dev/input/mice") 'char-special #o640 (device-number 13 63)) + (mknod (scope "dev/input/mouse0") 'char-special #o640 (device-number 13 32)) + (mknod (scope "dev/input/event0") 'char-special #o640 (device-number 13 64)) ;; TTYs. (mknod (scope "dev/tty") 'char-special #o600 @@ -133,6 +158,17 @@ Vanilla QEMU's `-smb' option just exports a /qemu share, whereas our (mount (string-append "//" server share) mount-point "cifs" 0 (string->pointer "guest,sec=none")))) +(define (mount-qemu-9p source mount-point) + "Mount QEMU's 9p file system from SOURCE at MOUNT-POINT. + +This uses the 'virtio' transport, which requires the various virtio Linux +modules to be loaded." + + (format #t "mounting QEMU's 9p share '~a'...\n" source) + (let ((server "10.0.2.4")) + (mount source mount-point "9p" 0 + (string->pointer "trans=virtio")))) + (define (bind-mount source target) "Bind-mount SOURCE at TARGET." (define MS_BIND 4096) ; from libc's <sys/mount.h> @@ -151,4 +187,155 @@ Vanilla QEMU's `-smb' option just exports a /qemu share, whereas our the last argument of `mknod'." (+ (* major 256) minor)) +(define* (boot-system #:key + (linux-modules '()) + qemu-guest-networking? + guile-modules-in-chroot? + volatile-root? + (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. + +When VOLATILE-ROOT? is true, the root file system is writable but any changes +to it are lost." + (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))) + + (define MS_RDONLY 1) + + (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 + (catch #t + (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. + ) + (mount root "/root" "ext3"))) + (lambda args + (format (current-error-port) "exception while mounting '~a': ~s~%" + root args) + (start-repl))) + (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))) + (('9p source target) + (let ((target (string-append "/root/" target))) + (mkdir-p target) + (mount-qemu-9p source target)))) + 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) + (chdir "/root") + (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 |