system: Add first-class file system declarations.
* gnu/system.scm (<operating-system>)[initrd]: Default to 'qemu-initrd'. (<file-system>): New record type. (operating-system-root-file-system): New procedure. (operating-system-derivation): Take the device name for GRUB from 'operating-system-root-file-system'. Pass the 'operating-system-initrd' procedure the list of boot file systems. * gnu/system/linux-initrd.scm (file-system->spec): New procedure. (qemu-initrd): Add 'file-systems' parameter, and remove #:mounts parameter. [file-system-type-predicate]: New procedure. [linux-modules]: Use it. Adjust #:mounts argument in 'boot-system' call. (gnu-system-initrd): Remove. * gnu/system/vm.scm (%linux-vm-file-systems): New variable. (expression->derivation-in-linux-vm): Adjust call to 'qemu-initrd'. (virtualized-operating-system): New procedure. (system-qemu-image/shared-store-script)[initrd]: Remove. Use 'virtualized-operating-system'. Get the 'initrd' file from OS-DRV. * guix/build/linux-initrd.scm (mount-qemu-smb-share, mount-qemu-9p): Remove. (MS_RDONLY, MS_BIND): New global variables. (bind-mount): Remove local 'MS_BIND' definition. (mount-root-file-system): New procedure, with code formerly in 'boot-system'. (mount-file-system): New procedure. (boot-system): Add #:root-fs-type parameter. Remove 'MS_RDONLY' local variable. Use 'mount-root-file-system' and 'mount-file-system'. * doc/guix.texi (Using the Configuration System): Add 'file-system' declaration.
This commit is contained in:
Ludovic Courtès
parent
f5d5a346db
commit
83bcd0b895
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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 "")
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
guile-modules-in-chroot?
|
||||
volatile-root?
|
||||
(mounts `((cifs "/store" ,(%store-prefix))
|
||||
(cifs "/xchg" "/xchg"))))
|
||||
"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:
|
||||
(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))))
|
||||
|
||||
(FILE-SYSTEM-TYPE SOURCE TARGET)
|
||||
(define* (qemu-initrd file-systems
|
||||
#:key
|
||||
guile-modules-in-chroot?
|
||||
volatile-root?)
|
||||
"Return a monadic derivation that builds an initrd for use in a QEMU guest
|
||||
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'.
|
||||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue