summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.dir-locals.el2
-rw-r--r--doc/guix.texi4
-rw-r--r--gnu/system.scm52
-rw-r--r--gnu/system/linux-initrd.scm47
-rw-r--r--gnu/system/vm.scm46
-rw-r--r--guix/build/linux-initrd.scm129
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