From 1c96c1bbabb9646aba2a3860cac02157f56c4dd1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 14 Apr 2014 23:59:08 +0200 Subject: linux-initrd: Mount / as a unionfs when asking for a volatile root. * guix/build/linux-initrd.scm (make-essential-device-nodes): Make /dev/fuse. (boot-system): Add #:unionfs parameter. Invoke UNIONFS instead of copying files over when VOLATILE-ROOT? is true. * gnu/system/linux-initrd.scm (expression->initrd): Add #:inputs parameter. [files-to-copy]: New procedure. [builder]: Add 'to-copy' parameter; honor it. (qemu-initrd)[linux-modules]: Add 'fuse.ko' when VOLATILE-ROOT?. Pass UNIONFS-FUSE/STATIC as #:inputs; change builder to pass #:unionfs to 'boot-system'. --- gnu/system/linux-initrd.scm | 75 +++++++++++++++++++++++++++++++++------------ 1 file changed, 56 insertions(+), 19 deletions(-) (limited to 'gnu/system/linux-initrd.scm') diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 42ca29cb5..786e06876 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -21,12 +21,15 @@ #:use-module (guix utils) #:use-module ((guix store) #:select (%store-prefix)) + #:use-module ((guix derivations) + #:select (derivation->output-path)) #:use-module (gnu packages cpio) #:use-module (gnu packages compression) #:use-module (gnu packages linux) #:use-module (gnu packages guile) #:use-module ((gnu packages make-bootstrap) #:select (%guile-static-stripped)) + #:use-module (ice-9 match) #:use-module (ice-9 regex) #:export (expression->initrd qemu-initrd @@ -49,12 +52,14 @@ (name "guile-initrd") (system (%current-system)) (modules '()) + (inputs '()) (linux #f) (linux-modules '())) "Return a package that contains a Linux initrd (a gzipped cpio archive) containing GUILE and that evaluates EXP upon booting. LINUX-MODULES is a list -of `.ko' file names to be copied from LINUX into the initrd. MODULES is a -list of Guile module names to be embedded in the initrd." +of `.ko' file names to be copied from LINUX into the initrd. INPUTS is a list +of additional inputs to be copied in the initrd. MODULES is a list of Guile +module names to be embedded in the initrd." ;; General Linux overview in `Documentation/early-userspace/README' and ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'. @@ -63,7 +68,16 @@ list of Guile module names to be embedded in the initrd." ;; Return a regexp that matches STR exactly. (string-append "^" (regexp-quote str) "$")) - (define builder + (define (files-to-copy) + (mlet %store-monad ((inputs (lower-inputs inputs))) + (return (map (match-lambda + ((_ drv) + (derivation->output-path drv)) + ((_ drv sub-drv) + (derivation->output-path drv sub-drv))) + inputs)))) + + (define (builder to-copy) `(begin (use-modules (guix build utils) (ice-9 pretty-print) @@ -137,6 +151,18 @@ list of Guile module names to be embedded in the initrd." ,module module-dir)))) linux-modules)) + ,@(if (null? to-copy) + '() + `((let ((store ,(string-append "." (%store-prefix)))) + (mkdir-p store) + ;; XXX: Should we do export-references-graph? + (for-each (lambda (input) + (let ((target + (string-append store "/" + (basename input)))) + (copy-recursively input target))) + ',to-copy)))) + ;; Reset the timestamps of all the files that will make it in the ;; initrd. (for-each (cut utime <> 0 0 0 0) @@ -184,8 +210,10 @@ list of Guile module names to be embedded in the initrd." ("modules/compiled" ,compiled) ,@(if linux `(("linux" ,linux)) - '()))))) - (derivation-expression name builder + '()) + ,@inputs))) + (to-copy (files-to-copy))) + (derivation-expression name (builder to-copy) #:modules '((guix build utils)) #:inputs inputs))) @@ -224,22 +252,31 @@ to it are lost." '()) ,@(if (assoc-ref mounts '9p) virtio-9p-modules + '()) + ,@(if volatile-root? + '("fuse.ko") '()))) - (expression->initrd - `(begin - (use-modules (guix build linux-initrd)) - - (boot-system #:mounts ',mounts - #:linux-modules ',linux-modules - #:qemu-guest-networking? #t - #:guile-modules-in-chroot? ',guile-modules-in-chroot? - #:volatile-root? ',volatile-root?)) - #:name "qemu-initrd" - #:modules '((guix build utils) - (guix build linux-initrd)) - #:linux linux-libre - #:linux-modules linux-modules)) + (mlet %store-monad + ((unionfs (package-file unionfs-fuse/static "bin/unionfs"))) + (expression->initrd + `(begin + (use-modules (guix build linux-initrd)) + + (boot-system #:mounts ',mounts + #:linux-modules ',linux-modules + #:qemu-guest-networking? #t + #:guile-modules-in-chroot? ',guile-modules-in-chroot? + #:unionfs ,unionfs + #:volatile-root? ',volatile-root?)) + #:name "qemu-initrd" + #:modules '((guix build utils) + (guix build linux-initrd)) + #:linux linux-libre + #:linux-modules linux-modules + #:inputs (if volatile-root? + `(("unionfs" ,unionfs-fuse/static)) + '())))) (define (gnu-system-initrd) "Initrd for the GNU system itself, with nothing QEMU-specific." -- cgit v1.3 From 0c21d92b1cb0f7fa2b2d43cae1d84d32ccfc1393 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 27 Apr 2014 23:06:15 +0200 Subject: linux-initrd: Rewrite using gexps. * gnu/system/linux-initrd.scm (expression->initrd): Rename 'inputs' parameter to 'to-copy'. Remove 'files-to-copy'. Rewrite 'builder' as a gexp, and use 'gexp->derivation'. (qemu-initrd): Adjust accordingly. --- gnu/system/linux-initrd.scm | 298 ++++++++++++++++++++------------------------ 1 file changed, 137 insertions(+), 161 deletions(-) (limited to 'gnu/system/linux-initrd.scm') diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 786e06876..6e04ad150 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -18,6 +18,7 @@ (define-module (gnu system linux-initrd) #:use-module (guix monads) + #:use-module (guix gexp) #:use-module (guix utils) #:use-module ((guix store) #:select (%store-prefix)) @@ -52,14 +53,14 @@ (name "guile-initrd") (system (%current-system)) (modules '()) - (inputs '()) + (to-copy '()) (linux #f) (linux-modules '())) "Return a package that contains a Linux initrd (a gzipped cpio archive) containing GUILE and that evaluates EXP upon booting. LINUX-MODULES is a list -of `.ko' file names to be copied from LINUX into the initrd. INPUTS is a list -of additional inputs to be copied in the initrd. MODULES is a list of Guile -module names to be embedded in the initrd." +of `.ko' file names to be copied from LINUX into the initrd. TO-COPY is a +list of additional derivations or packages to copy to the initrd. MODULES is +a list of Guile module names to be embedded in the initrd." ;; General Linux overview in `Documentation/early-userspace/README' and ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'. @@ -68,154 +69,129 @@ module names to be embedded in the initrd." ;; Return a regexp that matches STR exactly. (string-append "^" (regexp-quote str) "$")) - (define (files-to-copy) - (mlet %store-monad ((inputs (lower-inputs inputs))) - (return (map (match-lambda - ((_ drv) - (derivation->output-path drv)) - ((_ drv sub-drv) - (derivation->output-path drv sub-drv))) - inputs)))) + (mlet* %store-monad ((source (imported-modules modules)) + (compiled (compiled-modules modules))) + (define builder + ;; TODO: Move most of this code to (guix build linux-initrd). + #~(begin + (use-modules (guix build utils) + (ice-9 pretty-print) + (ice-9 popen) + (ice-9 match) + (ice-9 ftw) + (srfi srfi-26) + (system base compile) + (rnrs bytevectors) + ((system foreign) #:select (sizeof))) - (define (builder to-copy) - `(begin - (use-modules (guix build utils) - (ice-9 pretty-print) - (ice-9 popen) - (ice-9 match) - (ice-9 ftw) - (srfi srfi-26) - (system base compile) - (rnrs bytevectors) - ((system foreign) #:select (sizeof))) + (let ((cpio (string-append #$cpio "/bin/cpio")) + (gzip (string-append #$gzip "/bin/gzip")) + (modules #$source) + (gos #$compiled) + (scm-dir (string-append "share/guile/" (effective-version))) + (go-dir (format #f ".cache/guile/ccache/~a-~a-~a-~a" + (effective-version) + (if (eq? (native-endianness) (endianness little)) + "LE" + "BE") + (sizeof '*) + (effective-version)))) + (mkdir #$output) + (mkdir "contents") + (with-directory-excursion "contents" + (copy-recursively #$guile ".") + (call-with-output-file "init" + (lambda (p) + (format p "#!/bin/guile -ds~%!#~%" #$guile) + (pretty-print '#$exp p))) + (chmod "init" #o555) + (chmod "bin/guile" #o555) - (let ((guile (assoc-ref %build-inputs "guile")) - (cpio (string-append (assoc-ref %build-inputs "cpio") - "/bin/cpio")) - (gzip (string-append (assoc-ref %build-inputs "gzip") - "/bin/gzip")) - (modules (assoc-ref %build-inputs "modules")) - (gos (assoc-ref %build-inputs "modules/compiled")) - (scm-dir (string-append "share/guile/" (effective-version))) - (go-dir (format #f ".cache/guile/ccache/~a-~a-~a-~a" - (effective-version) - (if (eq? (native-endianness) (endianness little)) - "LE" - "BE") - (sizeof '*) - (effective-version))) - (out (assoc-ref %outputs "out"))) - (mkdir out) - (mkdir "contents") - (with-directory-excursion "contents" - (copy-recursively guile ".") - (call-with-output-file "init" - (lambda (p) - (format p "#!/bin/guile -ds~%!#~%" guile) - (pretty-print ',exp p))) - (chmod "init" #o555) - (chmod "bin/guile" #o555) + ;; Copy Guile modules. + (chmod scm-dir #o777) + (copy-recursively modules scm-dir + #:follow-symlinks? #t) + (copy-recursively gos (string-append "lib/guile/" + (effective-version) "/ccache") + #:follow-symlinks? #t) - ;; Copy Guile modules. - (chmod scm-dir #o777) - (copy-recursively modules scm-dir - #:follow-symlinks? #t) - (copy-recursively gos (string-append "lib/guile/" - (effective-version) "/ccache") - #:follow-symlinks? #t) + ;; Compile `init'. + (mkdir-p go-dir) + (set! %load-path (cons modules %load-path)) + (set! %load-compiled-path (cons gos %load-compiled-path)) + (compile-file "init" + #:opts %auto-compilation-options + #:output-file (string-append go-dir "/init.go")) - ;; Compile `init'. - (mkdir-p go-dir) - (set! %load-path (cons modules %load-path)) - (set! %load-compiled-path (cons gos %load-compiled-path)) - (compile-file "init" - #:opts %auto-compilation-options - #:output-file (string-append go-dir "/init.go")) + ;; Copy Linux modules. + (let* ((linux #$linux) + (module-dir (and linux + (string-append linux "/lib/modules")))) + (mkdir "modules") + #$@(map (lambda (module) + #~(match (find-files module-dir + #$(string->regexp module)) + ((file) + (format #t "copying '~a'...~%" file) + (copy-file file (string-append "modules/" + #$module))) + (() + (error "module not found" #$module module-dir)) + ((_ ...) + (error "several modules by that name" + #$module module-dir)))) + linux-modules)) - ;; Copy Linux modules. - (let* ((linux (assoc-ref %build-inputs "linux")) - (module-dir (and linux - (string-append linux "/lib/modules")))) - (mkdir "modules") - ,@(map (lambda (module) - `(match (find-files module-dir - ,(string->regexp module)) - ((file) - (format #t "copying '~a'...~%" file) - (copy-file file (string-append "modules/" - ,module))) - (() - (error "module not found" ,module module-dir)) - ((_ ...) - (error "several modules by that name" - ,module module-dir)))) - linux-modules)) + (let ((store #$(string-append "." (%store-prefix))) + (to-copy '#$to-copy)) + (unless (null? to-copy) + (mkdir-p store)) + ;; XXX: Should we do export-references-graph? + (for-each (lambda (input) + (let ((target + (string-append store "/" + (basename input)))) + (copy-recursively input target))) + to-copy)) - ,@(if (null? to-copy) - '() - `((let ((store ,(string-append "." (%store-prefix)))) - (mkdir-p store) - ;; XXX: Should we do export-references-graph? - (for-each (lambda (input) - (let ((target - (string-append store "/" - (basename input)))) - (copy-recursively input target))) - ',to-copy)))) + ;; Reset the timestamps of all the files that will make it in the + ;; initrd. + (for-each (cut utime <> 0 0 0 0) + (find-files "." ".*")) - ;; Reset the timestamps of all the files that will make it in the - ;; initrd. - (for-each (cut utime <> 0 0 0 0) - (find-files "." ".*")) + (system* cpio "--version") + (let ((pipe (open-pipe* OPEN_WRITE cpio "-o" + "-O" (string-append #$output "/initrd") + "-H" "newc" "--null"))) + (define print0 + (let ((len (string-length "./"))) + (lambda (file) + (format pipe "~a\0" (string-drop file len))))) - (system* cpio "--version") - (let ((pipe (open-pipe* OPEN_WRITE cpio "-o" - "-O" (string-append out "/initrd") - "-H" "newc" "--null"))) - (define print0 - (let ((len (string-length "./"))) - (lambda (file) - (format pipe "~a\0" (string-drop file len))))) + ;; Note: as per `ramfs-rootfs-initramfs.txt', always add + ;; directory entries before the files that are inside of it: "The + ;; Linux kernel cpio extractor won't create files in a directory + ;; that doesn't exist, so the directory entries must go before + ;; the files that go in those directories." + (file-system-fold (const #t) + (lambda (file stat result) ; leaf + (print0 file)) + (lambda (dir stat result) ; down + (unless (string=? dir ".") + (print0 dir))) + (const #f) ; up + (const #f) ; skip + (const #f) + #f + ".") - ;; Note: as per `ramfs-rootfs-initramfs.txt', always add - ;; directory entries before the files that are inside of it: "The - ;; Linux kernel cpio extractor won't create files in a directory - ;; that doesn't exist, so the directory entries must go before - ;; the files that go in those directories." - (file-system-fold (const #t) - (lambda (file stat result) ; leaf - (print0 file)) - (lambda (dir stat result) ; down - (unless (string=? dir ".") - (print0 dir))) - (const #f) ; up - (const #f) ; skip - (const #f) - #f - ".") + (and (zero? (close-pipe pipe)) + (with-directory-excursion #$output + (and (zero? (system* gzip "--best" "initrd")) + (rename-file "initrd.gz" "initrd"))))))))) - (and (zero? (close-pipe pipe)) - (with-directory-excursion out - (and (zero? (system* gzip "--best" "initrd")) - (rename-file "initrd.gz" "initrd"))))))))) - - (mlet* %store-monad - ((source (imported-modules modules)) - (compiled (compiled-modules modules)) - (inputs (lower-inputs - `(("guile" ,guile) - ("cpio" ,cpio) - ("gzip" ,gzip) - ("modules" ,source) - ("modules/compiled" ,compiled) - ,@(if linux - `(("linux" ,linux)) - '()) - ,@inputs))) - (to-copy (files-to-copy))) - (derivation-expression name (builder to-copy) - #:modules '((guix build utils)) - #:inputs inputs))) + (gexp->derivation name builder + #:modules '((guix build utils))))) (define* (qemu-initrd #:key guile-modules-in-chroot? @@ -257,26 +233,26 @@ to it are lost." '("fuse.ko") '()))) - (mlet %store-monad - ((unionfs (package-file unionfs-fuse/static "bin/unionfs"))) - (expression->initrd - `(begin - (use-modules (guix build linux-initrd)) + (expression->initrd + #~(begin + (use-modules (guix build linux-initrd) + (srfi srfi-26)) - (boot-system #:mounts ',mounts - #:linux-modules ',linux-modules - #:qemu-guest-networking? #t - #:guile-modules-in-chroot? ',guile-modules-in-chroot? - #:unionfs ,unionfs - #:volatile-root? ',volatile-root?)) - #:name "qemu-initrd" - #:modules '((guix build utils) - (guix build linux-initrd)) - #:linux linux-libre - #:linux-modules linux-modules - #:inputs (if volatile-root? - `(("unionfs" ,unionfs-fuse/static)) - '())))) + (boot-system #:mounts '#$mounts + #:linux-modules '#$linux-modules + #:qemu-guest-networking? #t + #:guile-modules-in-chroot? '#$guile-modules-in-chroot? + #:unionfs (and=> #$(and volatile-root? unionfs-fuse/static) + (cut string-append <> "/bin/unionfs")) + #:volatile-root? '#$volatile-root?)) + #:name "qemu-initrd" + #:modules '((guix build utils) + (guix build linux-initrd)) + #:to-copy (if volatile-root? + (list unionfs-fuse/static) + '()) + #:linux linux-libre + #:linux-modules linux-modules)) (define (gnu-system-initrd) "Initrd for the GNU system itself, with nothing QEMU-specific." -- cgit v1.3 From 83bcd0b895016c058807e71e102c54d2fab44339 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 3 May 2014 00:26:07 +0200 Subject: system: Add first-class file system declarations. * gnu/system.scm ()[initrd]: Default to 'qemu-initrd'. (): 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. --- .dir-locals.el | 2 + doc/guix.texi | 4 ++ gnu/system.scm | 52 ++++++++++++++++-- gnu/system/linux-initrd.scm | 47 ++++++++-------- gnu/system/vm.scm | 46 ++++++++++++---- guix/build/linux-initrd.scm | 129 ++++++++++++++++++++++---------------------- 6 files changed, 180 insertions(+), 100 deletions(-) (limited to 'gnu/system/linux-initrd.scm') diff --git a/.dir-locals.el b/.dir-locals.el index a6135b171..64a680c59 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 3ae2b7e00..99acad56e 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 6c94eb90c..7624b10ae 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-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 + 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 + (($ _ "/") #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 + (($ 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 6e04ad150..8b4ab9c4e 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 + (($ 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 db24c4e76..c08031741 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 4decc3b15..1e0d6e27e 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 . +(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 - (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 -- cgit v1.3 From 3c05b4bc2528ea64b259477bf58dbcc6a7739f78 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 May 2014 00:30:39 +0200 Subject: linux-initrd: Check the root and other early file systems. * gnu/system.scm (operating-system-derivation)[boot-file-systems]: Keep "/". * gnu/system/linux-initrd.scm (file-system->spec): Keep the 'check?' flag. (qemu-initrd)[helper-packages]: New variable. Pass it as #:to-copy. : Add 'set-path-environment-variable' call. Remove #:unionfs argument for 'boot-system'. * gnu/system/vm.scm (%linux-vm-file-systems): Add 'check?' field/ (virtualized-operating-system): Likewise for the "9p" file system. * guix/build/linux-initrd.scm (mount-root-file-system): Change #:unionfs default. Call 'check-file-system' before mounting ROOT, when VOLATILE-ROOT? is false. (check-file-system): New procedure. (mount-file-system): Honor 'check?' element in list; add 'check-file-system' call. (boot-system): Remove #:root-fs-type and #:unionfs parameters. [root-mount-point?, root-fs-type]: New variables. Call 'mount-file-system' on all MOUNTS but "/". --- gnu/system.scm | 6 +++-- gnu/system/linux-initrd.scm | 27 +++++++++++++++----- gnu/system/vm.scm | 9 ++++--- guix/build/linux-initrd.scm | 62 ++++++++++++++++++++++++++++++++++++--------- 4 files changed, 80 insertions(+), 24 deletions(-) (limited to 'gnu/system/linux-initrd.scm') diff --git a/gnu/system.scm b/gnu/system.scm index 7624b10ae..65d1ca341 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -349,8 +349,10 @@ we're running in the final root." "Return a derivation that builds OS." (define boot-file-systems (filter (match-lambda - (($ device mount-point type _ _ boot?) - (and boot? (not (string=? mount-point "/"))))) + (($ device "/") + #t) + (($ device mount-point type flags options boot?) + boot?)) (operating-system-file-systems os))) (mlet* %store-monad diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 8b4ab9c4e..749dfa313 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -198,8 +198,8 @@ a list of Guile module names to be embedded in the initrd." "Return a list corresponding to file-system FS that can be passed to the initrd code." (match fs - (($ device mount-point type flags options) - (list device mount-point type flags options)))) + (($ device mount-point type flags options _ check?) + (list device mount-point type flags options check?)))) (define* (qemu-initrd file-systems #:key @@ -243,24 +243,37 @@ exception and backtrace!)." '("fuse.ko") '()))) + (define helper-packages + ;; Packages to be copied on the initrd. + `(,@(if (find (lambda (fs) + (string-prefix? "ext" (file-system-type fs))) + file-systems) + (list e2fsck/static) + '()) + ,@(if volatile-root? + (list unionfs-fuse/static) + '()))) + (expression->initrd #~(begin (use-modules (guix build linux-initrd) + (guix build utils) (srfi srfi-26)) + (with-output-to-port (%make-void-port "w") + (lambda () + (set-path-environment-variable "PATH" '("bin" "sbin") + '#$helper-packages))) + (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? - #:unionfs (and=> #$(and volatile-root? unionfs-fuse/static) - (cut string-append <> "/bin/unionfs")) #:volatile-root? '#$volatile-root?)) #:name "qemu-initrd" #:modules '((guix build utils) (guix build linux-initrd)) - #:to-copy (if volatile-root? - (list unionfs-fuse/static) - '()) + #:to-copy helper-packages #:linux linux-libre #:linux-modules linux-modules)) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 786e56403..b20831f44 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -90,13 +90,15 @@ input tuple. The output file name is when building for SYSTEM." (device "store") (type "9p") (needed-for-boot? #t) - (options "trans=virtio")) + (options "trans=virtio") + (check? #f)) (file-system (mount-point "/xchg") (device "xchg") (type "9p") (needed-for-boot? #t) - (options "trans=virtio")))) + (options "trans=virtio") + (check? #f)))) (define* (expression->derivation-in-linux-vm name exp #:key @@ -333,7 +335,8 @@ environment with the store shared with the host." (device "store") (type "9p") (needed-for-boot? #t) - (options "trans=virtio")))))) + (options "trans=virtio") + (check? #f)))))) (define* (system-qemu-image/shared-store os diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index fd6c0c467..b2cbcae7d 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -190,7 +190,7 @@ the last argument of `mknod'." (+ (* major 256) minor)) (define* (mount-root-file-system root type - #:key volatile-root? unionfs) + #:key volatile-root? (unionfs "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." @@ -212,20 +212,45 @@ UNIONFS." "/rw-root=RW:/real-root=RO" "/root")) (error "unionfs failed"))) - (mount root "/root" type))) + (begin + (check-file-system root type) + (mount root "/root" type)))) (lambda args (format (current-error-port) "exception while mounting '~a': ~s~%" root args) (start-repl)))) +(define (check-file-system device type) + "Run a file system check of TYPE on DEVICE." + (define fsck + (string-append "fsck." type)) + + (let ((status (system* fsck "-v" "-p" device))) + (match (status:exit-val status) + (0 + #t) + (1 + (format (current-error-port) "'~a' corrected errors on ~a; continuing~%" + fsck device)) + (2 + (format (current-error-port) "'~a' corrected errors on ~a; rebooting~%" + fsck device) + (sleep 3) + (reboot)) + (code + (format (current-error-port) "'~a' exited with code ~a on ~a; spawning REPL~%" + fsck code device) + (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 TYPE (FLAGS ...) OPTIONS CHECK?) DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f; -FLAGS must be a list of symbols." +FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to +run a file system check." (define flags->bit-mask (match-lambda (('read-only rest ...) @@ -236,8 +261,10 @@ FLAGS must be a list of symbols." 0))) (match spec - ((source mount-point type (flags ...) options) + ((source mount-point type (flags ...) options check?) (let ((mount-point (string-append root "/" mount-point))) + (when check? + (check-file-system source type)) (mkdir-p mount-point) (mount source mount-point type (flags->bit-mask flags) (if options @@ -248,8 +275,7 @@ FLAGS must be a list of symbols." (linux-modules '()) qemu-guest-networking? guile-modules-in-chroot? - volatile-root? unionfs - (root-fs-type "ext4") + 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 @@ -257,8 +283,8 @@ 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'. -Mount the root file system, of type ROOT-FS-TYPE, specified by the '--root' -command-line argument, if any. +Mount the root file system, specified by the '--root' command-line argument, +if any. MOUNTS must be a list suitable for 'mount-file-system'. @@ -276,6 +302,18 @@ to it are lost." (resolve (string-append "/root" target))) file))) + (define root-mount-point? + (match-lambda + ((device "/" _ ...) #t) + (_ #f))) + + (define root-fs-type + (or (any (match-lambda + ((device "/" type _ ...) type) + (_ #f)) + mounts) + "ext4")) + (display "Welcome, this is GNU's early boot Guile.\n") (display "Use '--repl' for an initrd REPL.\n\n") @@ -310,8 +348,7 @@ to it are lost." (mkdir "/root")) (if root (mount-root-file-system root root-fs-type - #:volatile-root? volatile-root? - #:unionfs unionfs) + #:volatile-root? volatile-root?) (mount "none" "/root" "tmpfs")) (mount-essential-file-systems #:root "/root") @@ -321,7 +358,8 @@ to it are lost." (make-essential-device-nodes #:root "/root")) ;; Mount the specified file systems. - (for-each mount-file-system mounts) + (for-each mount-file-system + (remove root-mount-point? mounts)) (when guile-modules-in-chroot? ;; Copy the directories that contain .scm and .go files so that the -- cgit v1.3 From c5df183956016cf3205971f4fa30aa834dca3281 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 20 May 2014 21:59:08 +0200 Subject: Add (gnu system file-systems). This fixes a circular dependency between (gnu system) and (gnu system linux-initrd), where the latter could end up being compiled before 'file-system-type' was defined as a macro. * gnu/system.scm (, %fuse-control-file-system, %binary-format-file-system): Move to... * gnu/system/file-systems.scm: ... here. New file. * build-aux/hydra/demo-os.scm, gnu/system/linux-initrd.scm, gnu/system/vm.scm: Use it. * gnu-system.am (GNU_SYSTEM_MODULES): Add it. --- build-aux/hydra/demo-os.scm | 2 ++ gnu-system.am | 1 + gnu/system.scm | 53 ++------------------------------- gnu/system/file-systems.scm | 72 +++++++++++++++++++++++++++++++++++++++++++++ gnu/system/linux-initrd.scm | 2 +- gnu/system/vm.scm | 1 + 6 files changed, 79 insertions(+), 52 deletions(-) create mode 100644 gnu/system/file-systems.scm (limited to 'gnu/system/linux-initrd.scm') diff --git a/build-aux/hydra/demo-os.scm b/build-aux/hydra/demo-os.scm index fe9c77242..5f0fd6a6f 100644 --- a/build-aux/hydra/demo-os.scm +++ b/build-aux/hydra/demo-os.scm @@ -36,6 +36,8 @@ (gnu system grub) ; 'grub-configuration' (gnu system shadow) ; 'user-account' (gnu system linux) ; 'base-pam-services' + (gnu system file-systems) ; 'file-systems' + (gnu services base) (gnu services networking) (gnu services xorg)) diff --git a/gnu-system.am b/gnu-system.am index 66d54cba9..84a5e939f 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -248,6 +248,7 @@ GNU_SYSTEM_MODULES = \ gnu/services/xorg.scm \ \ gnu/system.scm \ + gnu/system/file-systems.scm \ gnu/system/grub.scm \ gnu/system/linux.scm \ gnu/system/linux-initrd.scm \ diff --git a/gnu/system.scm b/gnu/system.scm index dd4487846..6cb7d303d 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -34,6 +34,7 @@ #:use-module (gnu system shadow) #:use-module (gnu system linux) #:use-module (gnu system linux-initrd) + #:use-module (gnu system file-systems) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -56,20 +57,7 @@ operating-system-derivation operating-system-profile - operating-system-grub.cfg - - - 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 - - %fuse-control-file-system - %binary-format-file-system)) + operating-system-grub.cfg)) ;;; Commentary: ;;; @@ -129,43 +117,6 @@ (sudoers operating-system-sudoers ; /etc/sudoers contents (default %sudoers-specification))) - -;;; -;;; File systems. -;;; - -;; File system declaration. -(define-record-type* 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))) - -(define %fuse-control-file-system - ;; Control file system for Linux' file systems in user-space (FUSE). - (file-system - (device "fusectl") - (mount-point "/sys/fs/fuse/connections") - (type "fusectl") - (check? #f))) - -(define %binary-format-file-system - ;; Support for arbitrary executable binary format. - (file-system - (device "binfmt_misc") - (mount-point "/proc/sys/fs/binfmt_misc") - (type "binfmt_misc") - (check? #f))) - ;;; ;;; Derivation. diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm new file mode 100644 index 000000000..485150ea5 --- /dev/null +++ b/gnu/system/file-systems.scm @@ -0,0 +1,72 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu system file-systems) + #:use-module (guix records) + #:export ( + 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 + + %fuse-control-file-system + %binary-format-file-system)) + +;;; Commentary: +;;; +;;; Declaring file systems to be mounted. +;;; +;;; Code: + +;; File system declaration. +(define-record-type* 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))) + +(define %fuse-control-file-system + ;; Control file system for Linux' file systems in user-space (FUSE). + (file-system + (device "fusectl") + (mount-point "/sys/fs/fuse/connections") + (type "fusectl") + (check? #f))) + +(define %binary-format-file-system + ;; Support for arbitrary executable binary format. + (file-system + (device "binfmt_misc") + (mount-point "/proc/sys/fs/binfmt_misc") + (type "binfmt_misc") + (check? #f))) + +;;; file-systems.scm ends here diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 749dfa313..03199e0c3 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -30,7 +30,7 @@ #:use-module (gnu packages guile) #:use-module ((gnu packages make-bootstrap) #:select (%guile-static-stripped)) - #:use-module (gnu system) ; for 'file-system' + #:use-module (gnu system file-systems) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index ee9ac81ce..0d41791d8 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -42,6 +42,7 @@ #:use-module (gnu system linux) #:use-module (gnu system linux-initrd) #:use-module (gnu system grub) + #:use-module (gnu system file-systems) #:use-module (gnu system) #:use-module (gnu services) -- cgit v1.3 From 112440a7b832a3841bf8e8139975b43b78f8a6ab Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 23 May 2014 22:35:08 +0200 Subject: vm: Disable QEMU networking in the disk image initrd. * gnu/system/linux-initrd.scm (qemu-initrd): Add #:qemu-networking? parameter and honor it. * gnu/system/vm.scm (system-disk-image): Pass #:qemu-networking #f. --- gnu/system/linux-initrd.scm | 6 +++++- gnu/system/vm.scm | 6 +++++- 2 files changed, 10 insertions(+), 2 deletions(-) (limited to 'gnu/system/linux-initrd.scm') diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 03199e0c3..b80ff10f1 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -204,12 +204,16 @@ initrd code." (define* (qemu-initrd file-systems #:key guile-modules-in-chroot? + (qemu-networking? #t) 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 QEMU-NETWORKING? is true, set up networking with the standard QEMU +parameters. + When VOLATILE-ROOT? is true, the root file system is writable but any changes to it are lost. @@ -267,7 +271,7 @@ exception and backtrace!)." (boot-system #:mounts '#$(map file-system->spec file-systems) #:linux-modules '#$linux-modules - #:qemu-guest-networking? #t + #:qemu-guest-networking? #$qemu-networking? #:guile-modules-in-chroot? '#$guile-modules-in-chroot? #:volatile-root? '#$volatile-root?)) #:name "qemu-initrd" diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 18635fd7e..a15c4c358 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -271,7 +271,11 @@ to USB sticks meant to be read-only." (operating-system-file-systems os))) (let ((os (operating-system (inherit os) - (initrd (cut qemu-initrd <> #:volatile-root? volatile?)) + ;; Since this is meant to be used on real hardware, don't set up + ;; QEMU networking. + (initrd (cut qemu-initrd <> + #:volatile-root? volatile? + #:qemu-networking? #f)) ;; Force our own root file system. (file-systems (cons (file-system -- cgit v1.3