ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

system: Add first-class file system declarations.

Browse source 
* 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 2014-05-03 00:26:07 +02:00
parent f5d5a346db
commit 83bcd0b895
6 changed files with 182 additions and 102 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.dir-locals.el
View file

@ -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))

4
doc/guix.texi
View file

@ -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 "")

52
gnu/system.scm
View file

@ -51,9 +51,20 @@ (define-module (gnu system)
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 @@ (define-record-type* <operating-system> operating-system
(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 @@ (define-record-type* <operating-system> operating-system
(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 @@ (define setuid-progs
(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 @@ (define (operating-system-derivation os)
" (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)))

51
gnu/system/linux-initrd.scm
View file

@ -30,11 +30,12 @@ (define-module (gnu system linux-initrd)
#: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 @@ (define print0
(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 @@ (define virtio-9p-modules
;; 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 @@ (define linux-modules
(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 @@ (define linux-modules
#: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

46
gnu/system/vm.scm
View file

@ -82,6 +82,22 @@ (define* (input->name+output tuple #:key (system (%current-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 @@ (define* (expression->derivation-in-linux-vm name exp
(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 @@ (define* (system-qemu-image 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 @@ (define* (system-qemu-image/shared-store-script
(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 @@ (define builder
-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

129
guix/build/linux-initrd.scm
View file

@ -30,8 +30,7 @@ (define-module (guix build linux-initrd)
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 @@ (define* (configure-qemu-networking #:optional (interface "eth0"))
(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 @@ (define (device-number major minor)
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 @@ (define* (boot-system #:key
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 @@ (define (resolve 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")
@ -276,29 +306,9 @@ (define MS_RDONLY 1)
(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 @@ (define MS_RDONLY 1)
(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