diff options
| -rw-r--r-- | .dir-locals.el | 2 | ||||
| -rw-r--r-- | doc/guix.texi | 4 | ||||
| -rw-r--r-- | gnu/system.scm | 52 | ||||
| -rw-r--r-- | gnu/system/linux-initrd.scm | 47 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 46 | ||||
| -rw-r--r-- | guix/build/linux-initrd.scm | 129 |
6 files changed, 180 insertions, 100 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index a6135b171e..64a680c59f 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -17,6 +17,8 @@ (eval . (put 'with-directory-excursion 'scheme-indent-function 1)) (eval . (put 'package 'scheme-indent-function 0)) (eval . (put 'origin 'scheme-indent-function 0)) + (eval . (put 'operating-system 'scheme-indent-function 0)) + (eval . (put 'file-system 'scheme-indent-function 0)) (eval . (put 'manifest-entry 'scheme-indent-function 0)) (eval . (put 'manifest-pattern 'scheme-indent-function 0)) (eval . (put 'substitute-keyword-arguments 'scheme-indent-function 1)) diff --git a/doc/guix.texi b/doc/guix.texi index 3ae2b7e00b..99acad56e7 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3088,6 +3088,10 @@ Linux-Libre kernel, initial RAM disk, and boot loader looks like this: (host-name "komputilo") (timezone "Europe/Paris") (locale "fr_FR.UTF-8") + (file-systems (list (file-system + (device "/dev/disk/by-label/root") + (mount-point "/") + (type "ext3")))) (users (list (user-account (name "alice") (password "") diff --git a/gnu/system.scm b/gnu/system.scm index 6c94eb90c5..7624b10ae4 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -51,9 +51,20 @@ operating-system-timezone operating-system-locale operating-system-services + operating-system-file-systems operating-system-derivation - operating-system-profile)) + operating-system-profile + + <file-system> + file-system + file-system? + file-system-device + file-system-mount-point + file-system-type + file-system-needed-for-boot? + file-system-flags + file-system-options)) ;;; Commentary: ;;; @@ -72,8 +83,8 @@ (default grub)) (bootloader-entries operating-system-bootloader-entries ; list (default '())) - (initrd operating-system-initrd ; monadic derivation - (default (gnu-system-initrd))) + (initrd operating-system-initrd ; (list fs) -> M derivation + (default qemu-initrd)) (host-name operating-system-host-name) ; string @@ -112,6 +123,22 @@ (sudoers operating-system-sudoers ; /etc/sudoers contents (default %sudoers-specification))) +;; File system declaration. +(define-record-type* <file-system> file-system + make-file-system + file-system? + (device file-system-device) ; string + (mount-point file-system-mount-point) ; string + (type file-system-type) ; string + (flags file-system-flags ; list of symbols + (default '())) + (options file-system-options ; string or #f + (default #f)) + (needed-for-boot? file-system-needed-for-boot? ; Boolean + (default #f)) + (check? file-system-check? ; Boolean + (default #t))) + ;;; ;;; Derivation. @@ -311,16 +338,30 @@ we're running in the final root." (execl (string-append #$dmd "/bin/dmd") "dmd" "--config" #$dmd-conf))))) +(define (operating-system-root-file-system os) + "Return the root file system of OS." + (find (match-lambda + (($ <file-system> _ "/") #t) + (_ #f)) + (operating-system-file-systems os))) + (define (operating-system-derivation os) "Return a derivation that builds OS." + (define boot-file-systems + (filter (match-lambda + (($ <file-system> device mount-point type _ _ boot?) + (and boot? (not (string=? mount-point "/"))))) + (operating-system-file-systems os))) + (mlet* %store-monad ((profile (operating-system-profile os)) (etc (operating-system-etc-directory os)) (services (sequence %store-monad (operating-system-services os))) (boot (operating-system-boot-script os)) (kernel -> (operating-system-kernel os)) - (initrd (operating-system-initrd os)) + (initrd ((operating-system-initrd os) boot-file-systems)) (initrd-file -> #~(string-append #$initrd "/initrd")) + (root-fs -> (operating-system-root-file-system os)) (entries -> (list (menu-entry (label (string-append "GNU system with " @@ -328,7 +369,8 @@ we're running in the final root." " (technology preview)")) (linux kernel) (linux-arguments - (list "--root=/dev/sda1" + (list (string-append "--root=" + (file-system-device root-fs)) #~(string-append "--load=" #$boot))) (initrd initrd-file)))) (grub.cfg (grub-configuration-file entries))) diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 6e04ad150f..8b4ab9c4eb 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -30,11 +30,12 @@ #:use-module (gnu packages guile) #:use-module ((gnu packages make-bootstrap) #:select (%guile-static-stripped)) + #:use-module (gnu system) ; for 'file-system' #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) #:export (expression->initrd - qemu-initrd - gnu-system-initrd)) + qemu-initrd)) ;;; Commentary: @@ -193,24 +194,29 @@ a list of Guile module names to be embedded in the initrd." (gexp->derivation name builder #:modules '((guix build utils))))) -(define* (qemu-initrd #:key +(define (file-system->spec fs) + "Return a list corresponding to file-system FS that can be passed to the +initrd code." + (match fs + (($ <file-system> device mount-point type flags options) + (list device mount-point type flags options)))) + +(define* (qemu-initrd file-systems + #:key guile-modules-in-chroot? - volatile-root? - (mounts `((cifs "/store" ,(%store-prefix)) - (cifs "/xchg" "/xchg")))) + volatile-root?) "Return a monadic derivation that builds an initrd for use in a QEMU guest -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: +where the store is shared with the host. FILE-SYSTEMS is a list of +file-systems to be mounted by the initrd, possibly in addition to the root +file system specified on the kernel command line via '--root'. - (FILE-SYSTEM-TYPE SOURCE TARGET) +When VOLATILE-ROOT? is true, the root file system is writable but any changes +to it are lost. 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!). - -When VOLATILE-ROOT? is true, the root file system is writable but any changes -to it are lost." +exception and backtrace!)." (define cifs-modules ;; Modules needed to mount CIFS file systems. '("md4.ko" "ecb.ko" "cifs.ko")) @@ -219,14 +225,18 @@ to it are lost." ;; Modules for the 9p paravirtualized file system. '("9pnet.ko" "9p.ko" "9pnet_virtio.ko")) + (define (file-system-type-predicate type) + (lambda (fs) + (string=? (file-system-type fs) type))) + (define linux-modules ;; Modules added to the initrd and loaded from the initrd. `("virtio.ko" "virtio_ring.ko" "virtio_pci.ko" "virtio_balloon.ko" "virtio_blk.ko" "virtio_net.ko" - ,@(if (assoc-ref mounts 'cifs) + ,@(if (find (file-system-type-predicate "cifs") file-systems) cifs-modules '()) - ,@(if (assoc-ref mounts '9p) + ,@(if (find (file-system-type-predicate "9p") file-systems) virtio-9p-modules '()) ,@(if volatile-root? @@ -238,7 +248,7 @@ to it are lost." (use-modules (guix build linux-initrd) (srfi srfi-26)) - (boot-system #:mounts '#$mounts + (boot-system #:mounts '#$(map file-system->spec file-systems) #:linux-modules '#$linux-modules #:qemu-guest-networking? #t #:guile-modules-in-chroot? '#$guile-modules-in-chroot? @@ -254,9 +264,4 @@ to it are lost." #:linux linux-libre #:linux-modules linux-modules)) -(define (gnu-system-initrd) - "Initrd for the GNU system itself, with nothing QEMU-specific." - (qemu-initrd #:guile-modules-in-chroot? #f - #:mounts '())) - ;;; linux-initrd.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index db24c4e761..c080317415 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -82,6 +82,22 @@ input tuple. The output file name is when building for SYSTEM." ((input (and (? string?) (? store-path?) file)) (return `(,input . ,file)))))) +(define %linux-vm-file-systems + ;; File systems mounted for 'derivation-in-linux-vm'. The store and /xchg + ;; directory are shared with the host over 9p. + (list (file-system + (mount-point (%store-prefix)) + (device "store") + (type "9p") + (needed-for-boot? #t) + (options "trans=virtio")) + (file-system + (mount-point "/xchg") + (device "xchg") + (type "9p") + (needed-for-boot? #t) + (options "trans=virtio")))) + (define* (expression->derivation-in-linux-vm name exp #:key (system (%current-system)) @@ -130,9 +146,8 @@ made available under the /xchg CIFS share." (coreutils -> (car (assoc-ref %final-inputs "coreutils"))) (initrd (if initrd ; use the default initrd? (return initrd) - (qemu-initrd #:guile-modules-in-chroot? #t - #:mounts `((9p "store" ,(%store-prefix)) - (9p "xchg" "/xchg")))))) + (qemu-initrd %linux-vm-file-systems + #:guile-modules-in-chroot? #t)))) (define builder ;; Code that launches the VM that evaluates EXP. @@ -292,6 +307,22 @@ system as described by OS." #:initialize-store? #t #:inputs-to-copy `(("system" ,os-drv))))) +(define (virtualized-operating-system os) + "Return an operating system based on OS suitable for use in a virtualized +environment with the store shared with the host." + (operating-system (inherit os) + (initrd (cut qemu-initrd <> #:volatile-root? #t)) + (file-systems (list (file-system + (mount-point "/") + (device "/dev/vda1") + (type "ext3")) + (file-system + (mount-point (%store-prefix)) + (device "store") + (type "9p") + (needed-for-boot? #t) + (options "trans=virtio")))))) + (define* (system-qemu-image/shared-store os #:key (disk-image-size (* 15 (expt 2 20)))) @@ -314,14 +345,9 @@ with the host." (graphic? #t)) "Return a derivation that builds a script to run a virtual machine image of OS that shares its store with the host." - (define initrd - (qemu-initrd #:mounts `((9p "store" ,(%store-prefix))) - #:volatile-root? #t)) - (mlet* %store-monad - ((os -> (operating-system (inherit os) (initrd initrd))) + ((os -> (virtualized-operating-system os)) (os-drv (operating-system-derivation os)) - (initrd initrd) (image (system-qemu-image/shared-store os))) (define builder #~(call-with-output-file #$output @@ -332,7 +358,7 @@ exec " #$qemu "/bin/qemu-system-x86_64 -enable-kvm -no-reboot -net nic,model=vir -virtfs local,path=" #$(%store-prefix) ",security_model=none,mount_tag=store \ -net user \ -kernel " #$(operating-system-kernel os) "/bzImage \ - -initrd " #$initrd "/initrd \ + -initrd " #$os-drv "/initrd \ -append \"" #$(if graphic? "" "console=ttyS0 ") "--load=" #$os-drv "/boot --root=/dev/vda1\" \ -drive file=" #$image diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 4decc3b15c..1e0d6e27ec 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -30,8 +30,7 @@ linux-command-line make-essential-device-nodes configure-qemu-networking - mount-qemu-smb-share - mount-qemu-9p + mount-file-system bind-mount load-linux-module* device-number @@ -170,33 +169,12 @@ networking values.) Return #t if INTERFACE is up, #f otherwise." (logand (network-interface-flags sock interface) IFF_UP))) -(define (mount-qemu-smb-share share mount-point) - "Mount QEMU's CIFS/SMB SHARE at MOUNT-POINT. - -Vanilla QEMU's `-smb' option just exports a /qemu share, whereas our -`qemu-with-multiple-smb-shares' package exports the /xchg and /store shares - (the latter allows the store to be shared between the host and guest.)" - - (format #t "mounting QEMU's SMB share `~a'...\n" share) - (let ((server "10.0.2.4")) - (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")))) +;; Linux mount flags, from libc's <sys/mount.h>. +(define MS_RDONLY 1) +(define MS_BIND 4096) (define (bind-mount source target) "Bind-mount SOURCE at TARGET." - (define MS_BIND 4096) ; from libc's <sys/mount.h> - (mount source target "" MS_BIND)) (define (load-linux-module* file) @@ -211,11 +189,67 @@ modules to be loaded." the last argument of `mknod'." (+ (* major 256) minor)) +(define* (mount-root-file-system root type + #:key volatile-root? unionfs) + "Mount the root file system of type TYPE at device ROOT. If VOLATILE-ROOT? +is true, mount ROOT read-only and make it a union with a writable tmpfs using +UNIONFS." + (catch #t + (lambda () + (if volatile-root? + (begin + (mkdir-p "/real-root") + (mount root "/real-root" type MS_RDONLY) + (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,suid,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~%" + root args) + (start-repl)))) + +(define* (mount-file-system spec #:key (root "/root")) + "Mount the file system described by SPEC under ROOT. SPEC must have the +form: + + (DEVICE MOUNT-POINT TYPE (FLAGS ...) OPTIONS) + +DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f; +FLAGS must be a list of symbols." + (define flags->bit-mask + (match-lambda + (('read-only rest ...) + (or MS_RDONLY (flags->bit-mask rest))) + (('bind-mount rest ...) + (or MS_BIND (flags->bit-mask rest))) + (() + 0))) + + (match spec + ((source mount-point type (flags ...) options) + (let ((mount-point (string-append root "/" mount-point))) + (mkdir-p mount-point) + (mount source mount-point type (flags->bit-mask flags) + (if options + (string->pointer options) + %null-pointer)))))) + (define* (boot-system #:key (linux-modules '()) qemu-guest-networking? guile-modules-in-chroot? volatile-root? unionfs + (root-fs-type "ext3") (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 @@ -223,9 +257,7 @@ 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) +MOUNTS must be a list suitable for 'mount-file-system'. When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in the new root. @@ -241,8 +273,6 @@ to it are lost." (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") @@ -276,29 +306,9 @@ to it are lost." (unless (file-exists? "/root") (mkdir "/root")) (if root - (catch #t - (lambda () - (if volatile-root? - (begin - (mkdir-p "/real-root") - (mount root "/real-root" "ext3" MS_RDONLY) - (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,suid,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~%" - root args) - (start-repl))) + (mount-root-file-system root root-fs-type + #:volatile-root? volatile-root? + #:unionfs unionfs) (mount "none" "/root" "tmpfs")) (mount-essential-file-systems #:root "/root") @@ -308,16 +318,7 @@ to it are lost." (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) + (for-each mount-file-system mounts) (when guile-modules-in-chroot? ;; Copy the directories that contain .scm and .go files so that the |