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') 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 c47f0d8b71cd3b2dd1ed9fb90a997f5abecddb8b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 23 Apr 2014 16:53:36 +0200 Subject: vm: Clarify 'system-qemu-image/shared-store-script'. * gnu/system/vm.scm (system-qemu-image/shared-store-script): Move 'initrd' definition to the top-level. Have a single definition of 'initrd', 'image', and 'os-drv'. --- gnu/system/vm.scm | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 069ac3093..c491336cc 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -341,18 +341,21 @@ 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." - (let* ((initrd (qemu-initrd #:mounts `((9p "store" ,(%store-prefix))) - #:volatile-root? #t)) - (os (operating-system (inherit os) (initrd initrd)))) + (define initrd + (qemu-initrd #:mounts `((9p "store" ,(%store-prefix))) + #:volatile-root? #t)) + + (mlet* %store-monad + ((os -> (operating-system (inherit os) (initrd initrd))) + (os-drv (operating-system-derivation os)) + (initrd initrd) + (image (system-qemu-image/shared-store os))) (define builder - (mlet %store-monad ((image (system-qemu-image/shared-store os)) - (qemu (package-file qemu + (mlet %store-monad ((qemu (package-file qemu "bin/qemu-system-x86_64")) (bash (package-file bash "bin/sh")) (kernel (package-file (operating-system-kernel os) - "bzImage")) - (initrd initrd) - (os-drv (operating-system-derivation os))) + "bzImage"))) (return `(let ((out (assoc-ref %outputs "out"))) (call-with-output-file out (lambda (port) @@ -371,17 +374,14 @@ exec " ,qemu " -enable-kvm -no-reboot -net nic,model=virtio \ (chmod out #o555) #t)))) - (mlet %store-monad ((image (system-qemu-image/shared-store os)) - (initrd initrd) - (qemu (package->derivation qemu)) + (mlet %store-monad ((qemu (package->derivation qemu)) (bash (package->derivation bash)) - (os (operating-system-derivation os)) (builder builder)) (derivation-expression "run-vm.sh" builder #:inputs `(("qemu" ,qemu) ("image" ,image) ("bash" ,bash) ("initrd" ,initrd) - ("os" ,os)))))) + ("os" ,os-drv)))))) ;;; vm.scm ends here -- cgit v1.3 From 02100028bb78b9bb17764eab0f009fd6fa07fd7b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 26 Apr 2014 16:36:48 +0200 Subject: gnu: Use gexps in obvious places in (gnu system ...). * gnu/system.scm (operating-system-boot-script): Use 'gexp->file' instead of 'text-file*'. * gnu/system/vm.scm (expression->derivation-in-linux-vm): Likewise. (system-qemu-image/shared-store-script)[builder]: Turn into a gexp. Use 'gexp->derivation' instead of 'derivation-expression'. --- gnu/system.scm | 8 ++++---- gnu/system/vm.scm | 60 ++++++++++++++++++++++--------------------------------- 2 files changed, 28 insertions(+), 40 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system.scm b/gnu/system.scm index 93858e972..630886779 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -19,6 +19,7 @@ (define-module (gnu system) #:use-module (guix store) #:use-module (guix monads) + #:use-module (guix gexp) #:use-module (guix records) #:use-module (guix packages) #:use-module (guix derivations) @@ -333,10 +334,9 @@ we're running in the final root." (etc (operating-system-etc-directory os)) (dmd-conf (dmd-configuration-file services (derivation->output-path etc)))) - ;; FIXME: Use 'sexp-file' or similar. - (text-file* "boot" - "(execl \"" dmd "/bin/dmd\" \"dmd\" - \"--config\" \"" dmd-conf "\")"))) + (gexp->file "boot" + #~(execl (string-append #$dmd "/bin/dmd") + "dmd" "--config" #$dmd-conf)))) (define (operating-system-derivation os) "Return a derivation that builds OS." diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index c491336cc..82f9ec9a1 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -19,6 +19,7 @@ (define-module (gnu system vm) #:use-module (guix config) #:use-module (guix store) + #:use-module (guix gexp) #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix monads) @@ -158,12 +159,14 @@ made available under the /xchg CIFS share." ,exp)) (user-builder (text-file "builder-in-linux-vm" (object->string exp*))) - (loader (text-file* "linux-vm-loader" ; XXX: use 'sexp-file' - "(begin (set! %load-path (cons \"" - module-dir "\" %load-path)) " - "(set! %load-compiled-path (cons \"" - compiled "\" %load-compiled-path))" - "(primitive-load \"" user-builder "\"))")) + (loader (gexp->file "linux-vm-loader" + #~(begin + (set! %load-path + (cons #$module-dir %load-path)) + (set! %load-compiled-path + (cons #$compiled + %load-compiled-path)) + (primitive-load #$user-builder)))) (coreutils -> (car (assoc-ref %final-inputs "coreutils"))) (initrd (if initrd ; use the default initrd? (return initrd) @@ -351,37 +354,22 @@ OS that shares its store with the host." (initrd initrd) (image (system-qemu-image/shared-store os))) (define builder - (mlet %store-monad ((qemu (package-file qemu - "bin/qemu-system-x86_64")) - (bash (package-file bash "bin/sh")) - (kernel (package-file (operating-system-kernel os) - "bzImage"))) - (return `(let ((out (assoc-ref %outputs "out"))) - (call-with-output-file out - (lambda (port) - (display - (string-append "#!" ,bash " -exec " ,qemu " -enable-kvm -no-reboot -net nic,model=virtio \ - -virtfs local,path=" ,(%store-prefix) ",security_model=none,mount_tag=store \ + #~(call-with-output-file #$output + (lambda (port) + (display + (string-append "#!" #$bash "/bin/sh +exec " #$qemu "/bin/qemu-system-x86_64 -enable-kvm -no-reboot -net nic,model=virtio \ + -virtfs local,path=" #$(%store-prefix) ",security_model=none,mount_tag=store \ -net user \ - -kernel " ,kernel " -initrd " - ,(string-append (derivation->output-path initrd) "/initrd") " \ --append \"" ,(if graphic? "" "console=ttyS0 ") -"--load=" ,(derivation->output-path os-drv) "/boot --root=/dev/vda1\" \ - -drive file=" ,(derivation->output-path image) + -kernel " #$(operating-system-kernel os) "/bzImage \ + -initrd " #$initrd "/initrd \ +-append \"" #$(if graphic? "" "console=ttyS0 ") + "--load=" #$os-drv "/boot --root=/dev/vda1\" \ + -drive file=" #$image ",if=virtio,cache=writeback,werror=report,readonly\n") - port))) - (chmod out #o555) - #t)))) - - (mlet %store-monad ((qemu (package->derivation qemu)) - (bash (package->derivation bash)) - (builder builder)) - (derivation-expression "run-vm.sh" builder - #:inputs `(("qemu" ,qemu) - ("image" ,image) - ("bash" ,bash) - ("initrd" ,initrd) - ("os" ,os-drv)))))) + port) + (chmod port #o555)))) + + (gexp->derivation "run-vm.sh" builder))) ;;; vm.scm ends here -- cgit v1.3 From 1aa0033b646b59e62d6a05716a21c631fca55c77 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 27 Apr 2014 14:58:15 +0200 Subject: vm: Rewrite support procedures to use gexps. * gnu/system/vm.scm (%imported-modules): Remove. (expression->derivation-in-linux-vm): Remove 'inputs' parameter. Rename 'imported-modules' to 'modules'. Rewrite using gexps and 'gexp->derivation'. (qemu-image): Add 'qemu' parameter. Pass NAME to 'expression->derivation-in-linux-vm'. Rewrite using gexps. Remove #:inputs argument to 'expression->derivation-in-linux-vm'. (operating-system-default-contents): Rewrite using gexps. * gnu/system.scm (operating-system-profile-derivation): Rename to... (operating-system-profile): ... this. Adjust callers. (operating-system-profile-directory): Remove. --- gnu/system.scm | 15 ++-- gnu/system/vm.scm | 212 +++++++++++++++++++++++------------------------------- 2 files changed, 96 insertions(+), 131 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system.scm b/gnu/system.scm index 630886779..65b524d38 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -52,8 +52,8 @@ operating-system-locale operating-system-services - operating-system-profile-directory - operating-system-derivation)) + operating-system-derivation + operating-system-profile)) ;;; Commentary: ;;; @@ -282,17 +282,12 @@ alias ll='ls -l' ("tzdata" ,tzdata)) #:name "etc"))) -(define (operating-system-profile-derivation os) +(define (operating-system-profile os) "Return a derivation that builds the default profile of OS." ;; TODO: Replace with a real profile with a manifest. (union (operating-system-packages os) #:name "default-profile")) -(define (operating-system-profile-directory os) - "Return the directory name of the default profile of OS." - (mlet %store-monad ((drv (operating-system-profile-derivation os))) - (return (derivation->output-path drv)))) - (define (operating-system-accounts os) "Return the user accounts for OS, including an obligatory 'root' account." (mlet %store-monad ((services (sequence %store-monad @@ -317,7 +312,7 @@ alias ll='ls -l' (cons %pam-other-services (append-map service-pam-services services)))) (accounts (operating-system-accounts os)) - (profile-drv (operating-system-profile-derivation os)) + (profile-drv (operating-system-profile os)) (groups -> (append (operating-system-groups os) (append-map service-user-groups services)))) (etc-directory #:accounts accounts #:groups groups @@ -341,7 +336,7 @@ we're running in the final root." (define (operating-system-derivation os) "Return a derivation that builds OS." (mlet* %store-monad - ((profile-drv (operating-system-profile-derivation os)) + ((profile-drv (operating-system-profile os)) (profile -> (derivation->output-path profile-drv)) (etc-drv (operating-system-etc-directory os)) (etc -> (derivation->output-path etc-drv)) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 82f9ec9a1..db24c4e76 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -82,18 +82,14 @@ input tuple. The output file name is when building for SYSTEM." ((input (and (? string?) (? store-path?) file)) (return `(,input . ,file)))))) -;; An alias to circumvent name clashes. -(define %imported-modules imported-modules) - (define* (expression->derivation-in-linux-vm name exp #:key (system (%current-system)) - (inputs '()) (linux linux-libre) initrd (qemu qemu-headless) (env-vars '()) - (imported-modules + (modules '((guix build vm) (guix build linux-initrd) (guix build utils))) @@ -106,7 +102,7 @@ input tuple. The output file name is when building for SYSTEM." (disk-image-size (* 100 (expt 2 20)))) "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a -derivation). In the virtual machine, EXP has access to all of INPUTS from the +derivation). In the virtual machine, EXP has access to all its inputs from the store; it should put its output files in the `/xchg' directory, which is copied to the derivation's output when the VM terminates. The virtual machine runs with MEMORY-SIZE MiB of memory. @@ -114,51 +110,15 @@ runs with MEMORY-SIZE MiB of memory. When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of DISK-IMAGE-SIZE bytes and return it. -IMPORTED-MODULES is the set of modules imported in the execution environment -of EXP. +MODULES is the set of modules imported in the execution environment of EXP. When REFERENCES-GRAPHS is true, it must be a list of file name/store path pairs, as for `derivation'. The files containing the reference graphs are made available under the /xchg CIFS share." - ;; FIXME: Add #:modules parameter, for the 'use-modules' form. - - (define input-alist - (map input->name+output inputs)) - - (define builder - ;; Code that launches the VM that evaluates EXP. - `(let () - (use-modules (guix build utils) - (guix build vm)) - - (let ((linux (string-append (assoc-ref %build-inputs "linux") - "/bzImage")) - (initrd (string-append (assoc-ref %build-inputs "initrd") - "/initrd")) - (loader (assoc-ref %build-inputs "loader")) - (graphs ',(match references-graphs - (((graph-files . _) ...) graph-files) - (_ #f)))) - - (set-path-environment-variable "PATH" '("bin") - (map cdr %build-inputs)) - - (load-in-linux-vm loader - #:output (assoc-ref %outputs "out") - #:linux linux #:initrd initrd - #:memory-size ,memory-size - #:make-disk-image? ,make-disk-image? - #:disk-image-size ,disk-image-size - #:references-graphs graphs)))) - (mlet* %store-monad - ((input-alist (sequence %store-monad input-alist)) - (module-dir (%imported-modules imported-modules)) - (compiled (compiled-modules imported-modules)) - (exp* -> `(let ((%build-inputs ',input-alist)) - ,exp)) - (user-builder (text-file "builder-in-linux-vm" - (object->string exp*))) + ((module-dir (imported-modules modules)) + (compiled (compiled-modules modules)) + (user-builder (gexp->file "builder-in-linux-vm" exp)) (loader (gexp->file "linux-vm-loader" #~(begin (set! %load-path @@ -172,35 +132,50 @@ made available under the /xchg CIFS share." (return initrd) (qemu-initrd #:guile-modules-in-chroot? #t #:mounts `((9p "store" ,(%store-prefix)) - (9p "xchg" "/xchg"))))) - (inputs (lower-inputs `(("qemu" ,qemu) - ("linux" ,linux) - ("initrd" ,initrd) - ("coreutils" ,coreutils) - ("builder" ,user-builder) - ("loader" ,loader) - ,@inputs)))) - (derivation-expression name builder - ;; TODO: Require the "kvm" feature. - #:system system - #:inputs inputs - #:env-vars env-vars - #:modules (delete-duplicates - `((guix build utils) - (guix build vm) - (guix build linux-initrd) - ,@imported-modules)) - #:guile-for-build guile-for-build - #:references-graphs references-graphs))) + (9p "xchg" "/xchg")))))) + + (define builder + ;; Code that launches the VM that evaluates EXP. + #~(begin + (use-modules (guix build utils) + (guix build vm)) + + (let ((inputs '#$(list qemu coreutils)) + (linux (string-append #$linux "/bzImage")) + (initrd (string-append #$initrd "/initrd")) + (loader #$loader) + (graphs '#$(match references-graphs + (((graph-files . _) ...) graph-files) + (_ #f)))) + + (set-path-environment-variable "PATH" '("bin") inputs) + + (load-in-linux-vm loader + #:output #$output + #:linux linux #:initrd initrd + #:memory-size #$memory-size + #:make-disk-image? #$make-disk-image? + #:disk-image-size #$disk-image-size + #:references-graphs graphs)))) + + (gexp->derivation name builder + ;; TODO: Require the "kvm" feature. + #:system system + #:env-vars env-vars + #:modules `((guix build utils) + (guix build vm) + (guix build linux-initrd)) + #:guile-for-build guile-for-build + #:references-graphs references-graphs))) (define* (qemu-image #:key (name "qemu-image") (system (%current-system)) + (qemu qemu-headless) (disk-image-size (* 100 (expt 2 20))) grub-configuration (initialize-store? #f) (populate #f) - (inputs '()) (inputs-to-copy '())) "Return a bootable, stand-alone QEMU image. The returned image is a full disk image, with a GRUB installation that uses GRUB-CONFIGURATION as its @@ -218,41 +193,37 @@ such as /etc files." ((graph (sequence %store-monad (map input->name+output inputs-to-copy)))) (expression->derivation-in-linux-vm - "qemu-image" - `(let () - (use-modules (guix build vm) - (guix build utils)) - - (set-path-environment-variable "PATH" '("bin" "sbin") - (map cdr %build-inputs)) - - (let ((graphs ',(match inputs-to-copy - (((names . _) ...) - names)))) - (initialize-hard-disk #:grub.cfg ,grub-configuration - #:closures-to-copy graphs - #:disk-image-size ,disk-image-size - #:initialize-store? ,initialize-store? - #:directives ',populate) - (reboot))) + name + #~(begin + (use-modules (guix build vm) + (guix build utils)) + + (let ((inputs + '#$(append (list qemu parted grub e2fsprogs util-linux) + (map (compose car (cut assoc-ref %final-inputs <>)) + '("sed" "grep" "coreutils" "findutils" "gawk")) + (if initialize-store? (list guix) '()))) + + ;; This variable is unused but allows us to add INPUTS-TO-COPY + ;; as inputs. + (to-copy + '#$(map (match-lambda + ((name thing) thing) + ((name thing output) `(,thing ,output))) + inputs-to-copy))) + + (set-path-environment-variable "PATH" '("bin" "sbin") inputs) + + (let ((graphs '#$(match inputs-to-copy + (((names . _) ...) + names)))) + (initialize-hard-disk #:grub.cfg #$grub-configuration + #:closures-to-copy graphs + #:disk-image-size #$disk-image-size + #:initialize-store? #$initialize-store? + #:directives '#$populate) + (reboot)))) #:system system - #:inputs `(("parted" ,parted) - ("grub" ,grub) - ("e2fsprogs" ,e2fsprogs) - - ;; For shell scripts. - ("sed" ,(car (assoc-ref %final-inputs "sed"))) - ("grep" ,(car (assoc-ref %final-inputs "grep"))) - ("coreutils" ,(car (assoc-ref %final-inputs "coreutils"))) - ("findutils" ,(car (assoc-ref %final-inputs "findutils"))) - ("gawk" ,(car (assoc-ref %final-inputs "gawk"))) - ("util-linux" ,util-linux) - - ,@(if initialize-store? - `(("guix" ,guix)) - '()) - - ,@inputs-to-copy) #:make-disk-image? #t #:disk-image-size disk-image-size #:references-graphs graph))) @@ -283,29 +254,28 @@ basic contents of the root file system of OS." (gid (or (user-account-gid user) 0)) (root (string-append "/var/guix/profiles/per-user/" (user-account-name user)))) - `((directory ,root ,uid ,gid) - (directory ,home ,uid ,gid)))) + #~((directory #$root #$uid #$gid) + (directory #$home #$uid #$gid)))) (mlet* %store-monad ((os-drv (operating-system-derivation os)) - (os-dir -> (derivation->output-path os-drv)) (build-gid (operating-system-build-gid os)) - (profile (operating-system-profile-directory os))) - (return `((directory ,(%store-prefix) 0 ,(or build-gid 0)) - (directory "/etc") - (directory "/var/log") ; for dmd - (directory "/var/run/nscd") - (directory "/var/guix/gcroots") - ("/var/guix/gcroots/system" -> ,os-dir) - (directory "/run") - ("/run/current-system" -> ,profile) - (directory "/bin") - ("/bin/sh" -> "/run/current-system/bin/bash") - (directory "/tmp") - (directory "/var/guix/profiles/per-user/root" 0 0) - - (directory "/root" 0 0) ; an exception - ,@(append-map user-directories - (operating-system-users os)))))) + (profile (operating-system-profile os))) + (return #~((directory #$(%store-prefix) 0 #$(or build-gid 0)) + (directory "/etc") + (directory "/var/log") ; for dmd + (directory "/var/run/nscd") + (directory "/var/guix/gcroots") + ("/var/guix/gcroots/system" -> #$os-drv) + (directory "/run") + ("/run/current-system" -> #$profile) + (directory "/bin") + ("/bin/sh" -> "/run/current-system/bin/bash") + (directory "/tmp") + (directory "/var/guix/profiles/per-user/root" 0 0) + + (directory "/root" 0 0) ; an exception + #$@(append-map user-directories + (operating-system-users os)))))) (define* (system-qemu-image os #:key (disk-image-size (* 900 (expt 2 20)))) -- cgit v1.3 From b5f4e686359d8842b329e6b161ef89fa6c04ebc3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 Apr 2014 23:07:08 +0200 Subject: services: Rewrite using gexps. * gnu/services.scm ()[inputs]: Remove. * gnu/system.scm (links): Remove. (etc-directory): Add PASSWD and SHADOW to #:inputs. (operating-system-boot-script): Pass ETC to 'dmd-configuration-file'. (operating-system-derivation): Remove EXTRAS from the union. * gnu/system/linux.scm (pam-service->configuration): Rewrite in terms of 'gexp->derivation'. Compute the contents on the build side. Expect 'arguments' to contain a list of gexps. (pam-services->directory): Rewrite in terms of 'gexp->derivation'. (unix-pam-service): Change 'arguments' to a list of one gexp. * gnu/system/shadow.scm ()[inputs]: Remove. [shell]: Change default value to a gexp. (passwd-file): Rewrite in terms of 'gexp->derivation'. Compute contents on the build side. * gnu/services/base.scm (host-name-service, mingetty-service, nscd-service, syslog-service, guix-service): Change 'start' and 'stop' to gexps; remove 'inputs' field. (guix-build-accounts): Change 'shell' field to a gexp. * gnu/services/networking.scm (static-networking-service): Change 'start' and 'stop' to gexps; remove 'inputs' field. * gnu/services/xorg.scm (slim-service): Likewise. * gnu/services/dmd.scm (dmd-configuration-file): Expect ETC to be a derivation. Change 'config' to a gexp. Use 'gexp->file' instead of 'text-file'. * doc/guix.texi (Defining Services): Update nscd example with gexps, and without 'inputs'. Add xref to "G-Expressions". --- doc/guix.texi | 31 +++++++++--------- gnu/services.scm | 7 ++--- gnu/services/base.scm | 60 +++++++++++++++++------------------ gnu/services/dmd.scm | 77 +++++++++++++++++++++++---------------------- gnu/services/networking.scm | 58 +++++++++++++++++----------------- gnu/services/xorg.scm | 19 +++++------ gnu/system.scm | 44 +++++--------------------- gnu/system/linux.scm | 74 +++++++++++++++++++++---------------------- gnu/system/shadow.scm | 48 ++++++++++++---------------- 9 files changed, 187 insertions(+), 231 deletions(-) (limited to 'gnu/system') diff --git a/doc/guix.texi b/doc/guix.texi index 9fb226c65..bbfdce51f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3224,29 +3224,26 @@ like: @lisp (define (nscd-service) - (mlet %store-monad ((nscd (package-file glibc "sbin/nscd"))) + (with-monad %store-monad (return (service (documentation "Run libc's name service cache daemon.") (provision '(nscd)) - (start `(make-forkexec-constructor ,nscd "-f" "/dev/null" - "--foreground")) - (stop `(make-kill-destructor)) - - (respawn? #f) - (inputs `(("glibc" ,glibc))))))) + (start #~(make-forkexec-constructor + (string-append #$glibc "/sbin/nscd") + "-f" "/dev/null" "--foreground")) + (stop #~(make-kill-destructor)) + (respawn? #f))))) @end lisp @noindent -The @code{inputs} field specifies that this service depends on the -@var{glibc} package---the package that contains the @command{nscd} -program. The @code{start} and @code{stop} fields are expressions that -make use of dmd's facilities to start and stop processes (@pxref{Service -De- and Constructors,,, dmd, GNU dmd Manual}). The @code{provision} -field specifies the name under which this service is known to dmd, and -@code{documentation} specifies on-line documentation. Thus, the -commands @command{deco start ncsd}, @command{deco stop nscd}, and -@command{deco doc nscd} will do what you would expect (@pxref{Invoking -deco,,, dmd, GNU dmd Manual}). +The @code{start} and @code{stop} fields are G-expressions +(@pxref{G-Expressions}). They refer to dmd's facilities to start and +stop processes (@pxref{Service De- and Constructors,,, dmd, GNU dmd +Manual}). The @code{provision} field specifies the name under which +this service is known to dmd, and @code{documentation} specifies on-line +documentation. Thus, the commands @command{deco start ncsd}, +@command{deco stop nscd}, and @command{deco doc nscd} will do what you +would expect (@pxref{Invoking deco,,, dmd, GNU dmd Manual}). @c ********************************************************************* diff --git a/gnu/services.scm b/gnu/services.scm index eccde4e9a..8b89b11b8 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -26,7 +26,6 @@ service-respawn? service-start service-stop - service-inputs service-user-accounts service-user-groups service-pam-services)) @@ -47,11 +46,9 @@ (default '())) (respawn? service-respawn? ; Boolean (default #t)) - (start service-start) ; expression - (stop service-stop ; expression + (start service-start) ; g-expression + (stop service-stop ; g-expression (default #f)) - (inputs service-inputs ; list of inputs - (default '())) (user-accounts service-user-accounts ; list of (default '())) (user-groups service-user-groups ; list of diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 3145a657f..956199524 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -24,6 +24,7 @@ #:use-module ((gnu packages base) #:select (glibc-final)) #:use-module (gnu packages package-management) + #:use-module (guix gexp) #:use-module (guix monads) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -48,8 +49,8 @@ (return (service (documentation "Initialize the machine's host name.") (provision '(host-name)) - (start `(lambda _ - (sethostname ,name))) + (start #~(lambda _ + (sethostname #$name))) (respawn? #f))))) (define* (mingetty-service tty @@ -57,8 +58,7 @@ (motd (text-file "motd" "Welcome.\n")) (allow-empty-passwords? #t)) "Return a service to run mingetty on TTY." - (mlet %store-monad ((mingetty-bin (package-file mingetty "sbin/mingetty")) - (motd motd)) + (mlet %store-monad ((motd motd)) (return (service (documentation (string-append "Run mingetty on " tty ".")) @@ -68,10 +68,10 @@ ;; service to be done. (requirement '(host-name)) - (start `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty)) - (stop `(make-kill-destructor)) - (inputs `(("mingetty" ,mingetty) - ("motd" ,motd))) + (start #~(make-forkexec-constructor + (string-append #$mingetty "/sbin/mingetty") + "--noclear" #$tty)) + (stop #~(make-kill-destructor)) (pam-services ;; Let 'login' be known to PAM. All the mingetty services will have @@ -83,16 +83,17 @@ (define* (nscd-service #:key (glibc glibc-final)) "Return a service that runs libc's name service cache daemon (nscd)." - (mlet %store-monad ((nscd (package-file glibc "sbin/nscd"))) + (with-monad %store-monad (return (service (documentation "Run libc's name service cache daemon (nscd).") (provision '(nscd)) - (start `(make-forkexec-constructor ,nscd "-f" "/dev/null" - "--foreground")) - (stop `(make-kill-destructor)) + (start + #~(make-forkexec-constructor (string-append #$glibc "/sbin/nscd") + "-f" "/dev/null" + "--foreground")) + (stop #~(make-kill-destructor)) - (respawn? #f) - (inputs `(("glibc" ,glibc))))))) + (respawn? #f))))) (define (syslog-service) "Return a service that runs 'syslogd' with reasonable default settings." @@ -120,17 +121,17 @@ ") (mlet %store-monad - ((syslog.conf (text-file "syslog.conf" contents)) - (syslogd (package-file inetutils "libexec/syslogd"))) + ((syslog.conf (text-file "syslog.conf" contents))) (return (service (documentation "Run the syslog daemon (syslogd).") (provision '(syslogd)) - (start `(make-forkexec-constructor ,syslogd "--no-detach" - "--rcfile" ,syslog.conf)) - (stop `(make-kill-destructor)) - (inputs `(("inetutils" ,inetutils) - ("syslog.conf" ,syslog.conf))))))) + (start + #~(make-forkexec-constructor (string-append #$inetutils + "/libexec/syslogd") + "--no-detach" + "--rcfile" #$syslog.conf)) + (stop #~(make-kill-destructor)))))) (define* (guix-build-accounts count #:key (first-uid 30001) @@ -148,8 +149,7 @@ starting at FIRST-UID, and under GID." (gid gid) (comment (format #f "Guix Build User ~2d" n)) (home-directory "/var/empty") - (shell (package-file shadow "sbin/nologin")) - (inputs `(("shadow" ,shadow))))) + (shell #~(string-append #$shadow "/sbin/nologin")))) 1+ 1)))) @@ -157,16 +157,16 @@ starting at FIRST-UID, and under GID." (build-user-gid 30000) (build-accounts 10)) "Return a service that runs the build daemon from GUIX, and has BUILD-ACCOUNTS user accounts available under BUILD-USER-GID." - (mlet %store-monad ((daemon (package-file guix "bin/guix-daemon")) - (accounts (guix-build-accounts build-accounts + (mlet %store-monad ((accounts (guix-build-accounts build-accounts #:gid build-user-gid))) (return (service (provision '(guix-daemon)) - (start `(make-forkexec-constructor ,daemon - "--build-users-group" - ,builder-group)) - (stop `(make-kill-destructor)) - (inputs `(("guix" ,guix))) + (start + #~(make-forkexec-constructor (string-append #$guix + "/bin/guix-daemon") + "--build-users-group" + #$builder-group)) + (stop #~(make-kill-destructor)) (user-accounts accounts) (user-groups (list (user-group (name builder-group) diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index 54fb5cbfd..c187c0985 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -17,6 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu services dmd) + #:use-module (guix gexp) #:use-module (guix monads) #:use-module (gnu services) #:use-module (ice-9 match) @@ -31,50 +32,50 @@ (define (dmd-configuration-file services etc) "Return the dmd configuration file for SERVICES, that initializes /etc from -ETC (the name of a directory in the store) on startup." +ETC (the derivation that builds the /etc directory) on startup." (define config - `(begin - (use-modules (ice-9 ftw)) + #~(begin + (use-modules (ice-9 ftw)) - (register-services - ,@(map (lambda (service) - `(make - #:docstring ',(service-documentation service) - #:provides ',(service-provision service) - #:requires ',(service-requirement service) - #:respawn? ',(service-respawn? service) - #:start ,(service-start service) - #:stop ,(service-stop service))) - services)) + (register-services + #$@(map (lambda (service) + #~(make + #:docstring '#$(service-documentation service) + #:provides '#$(service-provision service) + #:requires '#$(service-requirement service) + #:respawn? '#$(service-respawn? service) + #:start #$(service-start service) + #:stop #$(service-stop service))) + services)) - ;; /etc is a mixture of static and dynamic settings. Here is where we - ;; initialize it from the static part. - (format #t "populating /etc from ~a...~%" ,etc) - (let ((rm-f (lambda (f) - (false-if-exception (delete-file f))))) - (rm-f "/etc/static") - (symlink ,etc "/etc/static") - (for-each (lambda (file) - ;; TODO: Handle 'shadow' specially so that changed - ;; password aren't lost. - (let ((target (string-append "/etc/" file)) - (source (string-append "/etc/static/" file))) - (rm-f target) - (symlink source target))) - (scandir ,etc - (lambda (file) - (not (member file '("." "..")))))) + ;; /etc is a mixture of static and dynamic settings. Here is where we + ;; initialize it from the static part. + (format #t "populating /etc from ~a...~%" #$etc) + (let ((rm-f (lambda (f) + (false-if-exception (delete-file f))))) + (rm-f "/etc/static") + (symlink #$etc "/etc/static") + (for-each (lambda (file) + ;; TODO: Handle 'shadow' specially so that changed + ;; password aren't lost. + (let ((target (string-append "/etc/" file)) + (source (string-append "/etc/static/" file))) + (rm-f target) + (symlink source target))) + (scandir #$etc + (lambda (file) + (not (member file '("." "..")))))) - ;; Prevent ETC from being GC'd. - (rm-f "/var/guix/gcroots/etc-directory") - (symlink ,etc "/var/guix/gcroots/etc-directory")) + ;; Prevent ETC from being GC'd. + (rm-f "/var/guix/gcroots/etc-directory") + (symlink #$etc "/var/guix/gcroots/etc-directory")) - ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it. - (setenv "PATH" "/run/current-system/bin") + ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it. + (setenv "PATH" "/run/current-system/bin") - (format #t "starting services...~%") - (for-each start ',(append-map service-provision services)))) + (format #t "starting services...~%") + (for-each start '#$(append-map service-provision services)))) - (text-file "dmd.conf" (object->string config))) + (gexp->file "dmd.conf" config)) ;;; dmd.scm ends here diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index 317800db5..552254173 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -20,6 +20,7 @@ #:use-module (gnu services) #:use-module (gnu packages admin) #:use-module (gnu packages linux) + #:use-module (guix gexp) #:use-module (guix monads) #:export (static-networking-service)) @@ -41,40 +42,41 @@ true, it must be a string specifying the default network gateway." ;; TODO: Eventually we should do this using Guile's networking procedures, ;; like 'configure-qemu-networking' does, but the patch that does this is ;; not yet in stock Guile. - (mlet %store-monad ((ifconfig (package-file inetutils "bin/ifconfig")) - (route (package-file net-tools "sbin/route"))) + (with-monad %store-monad (return (service (documentation (string-append "Set up networking on the '" interface "' interface using a static IP address.")) (provision '(networking)) - (start `(lambda _ - ;; Return #t if successfully started. - (and (zero? (system* ,ifconfig ,interface ,ip "up")) - ,(if gateway - `(zero? (system* ,route "add" "-net" "default" - "gw" ,gateway)) - #t) - ,(if (pair? name-servers) - `(call-with-output-file "/etc/resolv.conf" - (lambda (port) - (display - "# Generated by 'static-networking-service'.\n" - port) - (for-each (lambda (server) - (format port "nameserver ~a~%" - server)) - ',name-servers))) - #t)))) - (stop `(lambda _ + (start #~(lambda _ + ;; Return #t if successfully started. + (and (zero? (system* (string-append #$inetutils + "/bin/ifconfig") + #$interface #$ip "up")) + #$(if gateway + #~(zero? (system* (string-append #$net-tools + "/sbin/route") + "add" "-net" "default" + "gw" #$gateway)) + #t) + #$(if (pair? name-servers) + #~(call-with-output-file "/etc/resolv.conf" + (lambda (port) + (display + "# Generated by 'static-networking-service'.\n" + port) + (for-each (lambda (server) + (format port "nameserver ~a~%" + server)) + '#$name-servers))) + #t)))) + (stop #~(lambda _ ;; Return #f is successfully stopped. - (not (and (system* ,ifconfig ,interface "down") - (system* ,route "del" "-net" "default"))))) - (respawn? #f) - (inputs `(("inetutils" ,inetutils) - ,@(if gateway - `(("net-tools" ,net-tools)) - '()))))))) + (not (and (system* (string-append #$inetutils "/sbin/ifconfig") + #$interface "down") + (system* (string-append #$net-tools "/sbin/route") + "del" "-net" "default"))))) + (respawn? #f))))) ;;; networking.scm ends here diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index 086150a65..81b5bc17a 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -27,6 +27,7 @@ #:use-module (gnu packages gnustep) #:use-module (gnu packages admin) #:use-module (gnu packages bash) + #:use-module (guix gexp) #:use-module (guix monads) #:use-module (guix derivations) #:export (xorg-start-command @@ -190,9 +191,7 @@ reboot_cmd " dmd "/sbin/reboot (string-append "auto_login yes\ndefault_user " default-user) "")))) - (mlet %store-monad ((slim-bin (package-file slim "bin/slim")) - (bash-bin (package-file bash "bin/bash")) - (slim.cfg (slim.cfg))) + (mlet %store-monad ((slim.cfg (slim.cfg))) (return (service (documentation "Xorg display server") @@ -200,15 +199,11 @@ reboot_cmd " dmd "/sbin/reboot (requirement '(host-name)) (start ;; XXX: Work around the inability to specify env. vars. directly. - `(make-forkexec-constructor - ,bash-bin "-c" - ,(string-append "SLIM_CFGFILE=" (derivation->output-path slim.cfg) - " " slim-bin - " -nodaemon"))) - (stop `(make-kill-destructor)) - (inputs `(("slim" ,slim) - ("slim.cfg" ,slim.cfg) - ("bash" ,bash))) + #~(make-forkexec-constructor + (string-append #$bash "/bin/sh") "-c" + (string-append "SLIM_CFGFILE=" #$slim.cfg + " " #$slim "/bin/slim" " -nodaemon"))) + (stop #~(make-kill-destructor)) (respawn? #t) (pam-services ;; Tell PAM about 'slim'. diff --git a/gnu/system.scm b/gnu/system.scm index 65b524d38..20c49c182 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -192,29 +192,6 @@ as an inputs; additional inputs, such as derivations, are taken from INPUTS." #:inputs inputs #:local-build? #t)))) -(define (links inputs) - "Return a directory with symbolic links to all of INPUTS. This is -essentially useful when one wants to keep references to all of INPUTS, be they -directories or regular files." - (define builder - '(begin - (use-modules (srfi srfi-1)) - - (let ((out (assoc-ref %outputs "out"))) - (mkdir out) - (chdir out) - (fold (lambda (file number) - (symlink file (number->string number)) - (+ 1 number)) - 0 - (map cdr %build-inputs)) - #t))) - - (mlet %store-monad ((inputs (lower-inputs inputs))) - (derivation-expression "links" builder - #:inputs inputs - #:local-build? #t))) - (define* (etc-directory #:key (locale "C") (timezone "Europe/Paris") (accounts '()) @@ -272,12 +249,14 @@ alias ll='ls -l' ("shells" ,shells) ("profile" ,(derivation->output-path bashrc)) ("localtime" ,tz-file) - ("passwd" ,passwd) - ("shadow" ,shadow) + ("passwd" ,(derivation->output-path passwd)) + ("shadow" ,(derivation->output-path shadow)) ("group" ,group)))) (file-union files #:inputs `(("net" ,net-base) ("pam.d" ,pam.d) + ("passwd" ,passwd) + ("shadow" ,shadow) ("bashrc" ,bashrc) ("tzdata" ,tzdata)) #:name "etc"))) @@ -327,8 +306,7 @@ we're running in the final root." (mlet* %store-monad ((services (sequence %store-monad (operating-system-services os))) (etc (operating-system-etc-directory os)) - (dmd-conf (dmd-configuration-file services - (derivation->output-path etc)))) + (dmd-conf (dmd-configuration-file services etc))) (gexp->file "boot" #~(execl (string-append #$dmd "/bin/dmd") "dmd" "--config" #$dmd-conf)))) @@ -357,25 +335,19 @@ we're running in the final root." (linux-arguments `("--root=/dev/sda1" ,(string-append "--load=" boot))) (initrd initrd-file)))) - (grub.cfg (grub-configuration-file entries)) - (accounts (operating-system-accounts os)) - (extras (links (delete-duplicates - (append (append-map service-inputs services) - (append-map user-account-inputs accounts)))))) + (grub.cfg (grub-configuration-file entries))) (file-union `(("boot" ,boot) ("kernel" ,kernel-dir) ("initrd" ,initrd-file) ("profile" ,profile) ("grub.cfg" ,grub.cfg) - ("etc" ,etc) - ("system-inputs" ,(derivation->output-path extras))) + ("etc" ,etc)) #:inputs `(("boot" ,boot-drv) ("kernel" ,kernel) ("initrd" ,initrd) ("bash" ,bash) ("profile" ,profile-drv) - ("etc" ,etc-drv) - ("system-inputs" ,extras)) + ("etc" ,etc-drv)) #:name "system"))) ;;; system.scm ends here diff --git a/gnu/system/linux.scm b/gnu/system/linux.scm index 65868ce9b..efe27c55c 100644 --- a/gnu/system/linux.scm +++ b/gnu/system/linux.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Ludovic Courtès +;;; Copyright © 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,6 +21,7 @@ #:use-module (guix records) #:use-module (guix derivations) #:use-module (guix monads) + #:use-module (guix gexp) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -58,58 +59,56 @@ (define-record-type* pam-entry make-pam-entry pam-entry? - (control pam-entry-control) ; string - (module pam-entry-module) ; file name - (arguments pam-entry-arguments ; list of strings + (control pam-entry-control) ; string + (module pam-entry-module) ; file name + (arguments pam-entry-arguments ; list of string-valued g-expressions (default '()))) (define (pam-service->configuration service) - "Return the configuration string for SERVICE, to be dumped in -/etc/pam.d/NAME, where NAME is the name of SERVICE." - (define (entry->string type entry) + "Return the derivation building the configuration file for SERVICE, to be +dumped in /etc/pam.d/NAME, where NAME is the name of SERVICE." + (define (entry->gexp type entry) (match entry (($ control module (arguments ...)) - (string-append type " " - control " " module " " - (string-join arguments) - "\n")))) + #~(format #t "~a ~a ~a ~a~%" + #$type #$control #$module + (string-join (list #$@arguments)))))) (match service (($ name account auth password session) - (string-concatenate - (append (map (cut entry->string "account" <>) account) - (map (cut entry->string "auth" <>) auth) - (map (cut entry->string "password" <>) password) - (map (cut entry->string "session" <>) session)))))) + (define builder + #~(begin + (with-output-to-file #$output + (lambda () + #$@(append (map (cut entry->gexp "account" <>) account) + (map (cut entry->gexp "auth" <>) auth) + (map (cut entry->gexp "password" <>) password) + (map (cut entry->gexp "session" <>) session)) + #t)))) + + (gexp->derivation name builder)))) (define (pam-services->directory services) "Return the derivation to build the configuration directory to be used as /etc/pam.d for SERVICES." (mlet %store-monad ((names -> (map pam-service-name services)) - (files (mapm %store-monad - (match-lambda - ((and service ($ name)) - (let ((config (pam-service->configuration service))) - (text-file (string-append name ".pam") config)))) - - ;; XXX: Eventually, SERVICES may be a list of monadic - ;; values instead of plain values. - (map return services)))) + (files (sequence %store-monad + (map pam-service->configuration + ;; XXX: Eventually, SERVICES may be a list of + ;; monadic values instead of plain values. + services)))) (define builder - '(begin - (use-modules (ice-9 match)) + #~(begin + (use-modules (ice-9 match)) - (let ((out (assoc-ref %outputs "out"))) - (mkdir out) - (for-each (match-lambda - ((name . file) - (symlink file (string-append out "/" name)))) - %build-inputs) - #t))) + (mkdir #$output) + (for-each (match-lambda + ((name file) + (symlink file (string-append #$output "/" name)))) + '#$(zip names files)))) - (derivation-expression "pam.d" builder - #:inputs (zip names files)))) + (gexp->derivation "pam.d" builder))) (define %pam-other-services ;; The "other" PAM configuration, which denies everything (see @@ -149,7 +148,8 @@ should be the name of a file used as the message-of-the-day." (pam-entry (control "optional") (module "pam_motd.so") - (arguments (list (string-append "motd=" motd))))) + (arguments + (list #~(string-append "motd=" #$motd))))) (list unix)))))))) ;;; linux.scm ends here diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index 2a85a20eb..52242ee4e 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Ludovic Courtès +;;; Copyright © 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +20,7 @@ #:use-module (guix store) #:use-module (guix records) #:use-module (guix packages) + #:use-module (guix gexp) #:use-module (guix monads) #:use-module ((gnu packages admin) #:select (shadow)) @@ -35,7 +36,6 @@ user-account-comment user-account-home-directory user-account-shell - user-account-inputs user-group user-group? @@ -63,9 +63,8 @@ (gid user-account-gid) (comment user-account-comment (default "")) (home-directory user-account-home-directory) - (shell user-account-shell ; monadic value - (default (package-file bash "bin/bash"))) - (inputs user-account-inputs (default `(("bash" ,bash))))) + (shell user-account-shell ; gexp + (default #~(string-append #$bash "/bin/bash")))) (define-record-type* user-group make-user-group @@ -97,29 +96,22 @@ SHADOW? is true, then it is a /etc/shadow file, otherwise it is a /etc/passwd file." ;; XXX: The resulting file is world-readable, so beware when SHADOW? is #t! - (define (contents) - (with-monad %store-monad - (let loop ((accounts accounts) - (result '())) - (match accounts - ((($ name pass uid gid comment home-dir mshell) - rest ...) - (mlet %store-monad ((shell mshell)) - (loop rest - (cons (if shadow? - (string-append name - ":" ; XXX: use (crypt PASS …)? - ":::::::") - (string-append name - ":" "x" - ":" (number->string uid) - ":" (number->string gid) - ":" comment ":" home-dir ":" shell)) - result)))) - (() - (return (string-join (reverse result) "\n" 'suffix))))))) + (define account-exp + (match-lambda + (($ name pass uid gid comment home-dir shell) + (if shadow? ; XXX: use (crypt PASS …)? + #~(format #t "~a::::::::~%" #$name) + #~(format #t "~a:x:~a:~a:~a:~a:~a~%" + #$name #$(number->string uid) #$(number->string gid) + #$comment #$home-dir #$shell))))) - (mlet %store-monad ((contents (contents))) - (text-file (if shadow? "shadow" "passwd") contents))) + (define builder + #~(begin + (with-output-to-file #$output + (lambda () + #$@(map account-exp accounts) + #t)))) + + (gexp->derivation (if shadow? "shadow" "passwd") builder)) ;;; shadow.scm ends here -- cgit v1.3 From f6a7b21df7b499e8d304cc96fc949ec889e1eb10 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 Apr 2014 23:40:24 +0200 Subject: system: grub: Rewrite using gexps. * gnu/system/grub.scm (grub-configuration-file): Rewrite using 'gexp->derivation'. * gnu/system.scm (operating-system-derivation): Adjust accordingly. --- gnu/system.scm | 15 +++++++-------- gnu/system/grub.scm | 53 ++++++++++++++++++++++++----------------------------- 2 files changed, 31 insertions(+), 37 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system.scm b/gnu/system.scm index b52daf791..0b2501392 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -282,26 +282,25 @@ we're running in the final root." ((profile (operating-system-profile os)) (etc (operating-system-etc-directory os)) (services (sequence %store-monad (operating-system-services os))) - (boot-drv (operating-system-boot-script os)) - (boot -> (derivation->output-path boot-drv)) + (boot (operating-system-boot-script os)) (kernel -> (operating-system-kernel os)) (initrd (operating-system-initrd os)) - (initrd-file -> (string-append (derivation->output-path initrd) - "/initrd")) + (initrd-file -> #~(string-append #$initrd "/initrd")) (entries -> (list (menu-entry (label (string-append "GNU system with " (package-full-name kernel) " (technology preview)")) (linux kernel) - (linux-arguments `("--root=/dev/sda1" - ,(string-append "--load=" boot))) + (linux-arguments + (list "--root=/dev/sda1" + #~(string-append "--load=" #$boot))) (initrd initrd-file)))) (grub.cfg (grub-configuration-file entries))) (file-union "system" - `(("boot" ,#~#$boot-drv) + `(("boot" ,#~#$boot) ("kernel" ,#~#$kernel) - ("initrd" ,#~(string-append #$initrd "/initrd")) + ("initrd" ,initrd-file) ("profile" ,#~#$profile) ("grub.cfg" ,#~#$grub.cfg) ("etc" ,#~#$etc))))) diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm index 5dc0b85ff..1893672a2 100644 --- a/gnu/system/grub.scm +++ b/gnu/system/grub.scm @@ -22,6 +22,7 @@ #:use-module (guix derivations) #:use-module (guix records) #:use-module (guix monads) + #:use-module (guix gexp) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:export (menu-entry @@ -40,45 +41,39 @@ (label menu-entry-label) (linux menu-entry-linux) (linux-arguments menu-entry-linux-arguments - (default '())) - (initrd menu-entry-initrd)) ; file name of the initrd + (default '())) ; list of string-valued gexps + (initrd menu-entry-initrd)) ; file name of the initrd as a gexp (define* (grub-configuration-file entries #:key (default-entry 1) (timeout 5) (system (%current-system))) "Return the GRUB configuration file for ENTRIES, a list of objects, defaulting to DEFAULT-ENTRY and with the given TIMEOUT." - (define (prologue kernel) - (format #f " -set default=~a -set timeout=~a -search.file ~a~%" - default-entry timeout kernel)) - - (define (bzImage) - (any (match-lambda - (($ _ linux) - (package-file linux "bzImage" - #:system system))) - entries)) - - (define entry->text + (define entry->gexp (match-lambda (($ label linux arguments initrd) - (mlet %store-monad ((linux (package-file linux "bzImage" - #:system system))) - (return (format #f "menuentry ~s { - linux ~a ~a + #~(format port "menuentry ~s { + linux ~a/bzImage ~a initrd ~a }~%" - label - linux (string-join arguments) initrd)))))) + #$label + #$linux (string-join (list #$@arguments)) + #$initrd)))) + + (define builder + #~(call-with-output-file #$output + (lambda (port) + (format port " +set default=~a +set timeout=~a +search.file ~a/bzImage~%" + #$default-entry #$timeout + #$(any (match-lambda + (($ _ linux) + linux)) + entries)) + #$@(map entry->gexp entries)))) - (mlet %store-monad ((kernel (bzImage)) - (body (sequence %store-monad - (map entry->text entries)))) - (text-file "grub.cfg" - (string-append (prologue kernel) - (string-concatenate body))))) + (gexp->derivation "grub.cfg" builder)) ;;; grub.scm ends here -- 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') 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 09e028f45feca1c415cd961ac5c79e5c7d5f3ae7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 30 Apr 2014 22:17:56 +0200 Subject: system: Add support for setuid binaries. * gnu/system.scm ()[pam-services, setuid-programs]: New fields. (etc-directory)[bashrc]: Prepend /run/setuid-programs to $PATH. (operating-system-etc-directory): Honor 'operating-system-pam-services'. (%setuid-programs): New variable. (operating-system-boot-script): Add (guix build utils) to the set of imported modules. Call 'activate-setuid-programs' in boot script. * gnu/system/linux.scm (base-pam-services): New procedure. * guix/build/activation.scm (%setuid-directory): New variable. (activate-setuid-programs): New procedure. * build-aux/hydra/demo-os.scm: Add 'pam-services' field. --- build-aux/hydra/demo-os.scm | 4 ++++ gnu/system.scm | 33 ++++++++++++++++++++++++++++----- gnu/system/linux.scm | 11 +++++++++-- guix/build/activation.scm | 36 +++++++++++++++++++++++++++++++++++- 4 files changed, 76 insertions(+), 8 deletions(-) (limited to 'gnu/system') diff --git a/build-aux/hydra/demo-os.scm b/build-aux/hydra/demo-os.scm index c2ff012a1..3987c4048 100644 --- a/build-aux/hydra/demo-os.scm +++ b/build-aux/hydra/demo-os.scm @@ -34,6 +34,7 @@ (gnu packages package-management) (gnu system shadow) ; 'user-account' + (gnu system linux) ; 'base-pam-services' (gnu services base) (gnu services networking) (gnu services xorg)) @@ -56,6 +57,9 @@ #:gateway "10.0.2.2") %base-services)) + (pam-services + ;; Explicitly allow for empty passwords. + (base-pam-services #:allow-empty-passwords? #t)) (packages (list bash coreutils findutils grep sed procps psmisc less guile-2.0 dmd guix util-linux inetutils diff --git a/gnu/system.scm b/gnu/system.scm index 4a8585758..ba105e2df 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -106,7 +106,12 @@ (locale operating-system-locale) ; string (services operating-system-services ; list of monadic services - (default %base-services))) + (default %base-services)) + + (pam-services operating-system-pam-services ; list of PAM services + (default (base-pam-services))) + (setuid-programs operating-system-setuid-programs + (default %setuid-programs))) ; list of string-valued gexps @@ -191,6 +196,7 @@ export TZ=\"" timezone "\" export TZDIR=\"" tzdata "/share/zoneinfo\" export PATH=$HOME/.guix-profile/bin:" profile "/bin:" profile "/sbin +export PATH=/run/setuid-programs:$PATH export CPATH=$HOME/.guix-profile/include:" profile "/include export LIBRARY_PATH=$HOME/.guix-profile/lib:" profile "/lib alias ls='ls -p --color' @@ -238,8 +244,8 @@ alias ll='ls -l' (pam-services -> ;; Services known to PAM. (delete-duplicates - (cons %pam-other-services - (append-map service-pam-services services)))) + (append (operating-system-pam-services os) + (append-map service-pam-services services)))) (accounts (operating-system-accounts os)) (profile-drv (operating-system-profile os)) (groups -> (append (operating-system-groups os) @@ -250,15 +256,29 @@ alias ll='ls -l' #:timezone (operating-system-timezone os) #:profile profile-drv))) +(define %setuid-programs + ;; Default set of setuid-root programs. + (let ((shadow (@ (gnu packages admin) shadow))) + (list #~(string-append #$shadow "/bin/passwd") + #~(string-append #$shadow "/bin/su") + #~(string-append #$inetutils "/bin/ping")))) + (define (operating-system-boot-script os) "Return the boot script for OS---i.e., the code started by the initrd once we're running in the final root." + (define %modules + '((guix build activation) + (guix build utils))) + (mlet* %store-monad ((services (sequence %store-monad (operating-system-services os))) (etc (operating-system-etc-directory os)) - (modules (imported-modules '((guix build activation)))) - (compiled (compiled-modules '((guix build activation)))) + (modules (imported-modules %modules)) + (compiled (compiled-modules %modules)) (dmd-conf (dmd-configuration-file services))) + (define setuid-progs + (operating-system-setuid-programs os)) + (gexp->file "boot" #~(begin (eval-when (expand load eval) @@ -272,6 +292,9 @@ we're running in the final root." ;; Populate /etc. (activate-etc #$etc) + ;; Activate setuid programs. + (activate-setuid-programs (list #$@setuid-progs)) + ;; Start dmd. (execl (string-append #$dmd "/bin/dmd") "dmd" "--config" #$dmd-conf))))) diff --git a/gnu/system/linux.scm b/gnu/system/linux.scm index efe27c55c..4030d8860 100644 --- a/gnu/system/linux.scm +++ b/gnu/system/linux.scm @@ -29,8 +29,8 @@ #:export (pam-service pam-entry pam-services->directory - %pam-other-services - unix-pam-service)) + unix-pam-service + base-pam-services)) ;;; Commentary: ;;; @@ -152,4 +152,11 @@ should be the name of a file used as the message-of-the-day." (list #~(string-append "motd=" #$motd))))) (list unix)))))))) +(define* (base-pam-services #:key allow-empty-passwords?) + "Return the list of basic PAM services everyone would want." + (list %pam-other-services + (unix-pam-service "su" #:allow-empty-passwords? allow-empty-passwords?) + (unix-pam-service "passwd" + #:allow-empty-passwords? allow-empty-passwords?))) + ;;; linux.scm ends here diff --git a/guix/build/activation.scm b/guix/build/activation.scm index c8491677d..6930a8c58 100644 --- a/guix/build/activation.scm +++ b/guix/build/activation.scm @@ -17,8 +17,10 @@ ;;; along with GNU Guix. If not, see . (define-module (guix build activation) + #:use-module (guix build utils) #:use-module (ice-9 ftw) - #:export (activate-etc)) + #:export (activate-etc + activate-setuid-programs)) ;;; Commentary: ;;; @@ -60,4 +62,36 @@ (rm-f "/var/guix/gcroots/etc-directory") (symlink etc "/var/guix/gcroots/etc-directory"))) +(define %setuid-directory + ;; Place where setuid programs are stored. + "/run/setuid-programs") + +(define (activate-setuid-programs programs) + "Turn PROGRAMS, a list of file names, into setuid programs stored under +%SETUID-DIRECTORY." + (define (make-setuid-program prog) + (let ((target (string-append %setuid-directory + "/" (basename prog)))) + (catch 'system-error + (lambda () + (link prog target)) + (lambda args + ;; Perhaps PROG and TARGET live in a different file system, so copy + ;; PROG. + (copy-file prog target))) + (chown target 0 0) + (chmod target #o6555))) + + (format #t "setting up setuid programs in '~a'...~%" + %setuid-directory) + (if (file-exists? %setuid-directory) + (for-each delete-file + (scandir %setuid-directory + (lambda (file) + (not (member file '("." "..")))) + string)[groups]: Change default to just the 'root' group. [sudoers]: New field. (etc-directory): Add #:sudoers parameter. Add 'sudoers' to the file union. (operating-system-etc-directory): Pass #:sudoers to 'etc-directory'. (%setuid-programs): Add 'sudo'. (%sudoers-specification): New variable. * gnu/system/linux.scm (base-pam-services): Add 'sudo'. * build-aux/hydra/demo-os.scm: Add 'groups' field; add 'guest' to the 'wheel' group. --- build-aux/hydra/demo-os.scm | 9 +++++++++ gnu/system.scm | 30 +++++++++++++++++++++--------- gnu/system/linux.scm | 2 ++ 3 files changed, 32 insertions(+), 9 deletions(-) (limited to 'gnu/system') diff --git a/build-aux/hydra/demo-os.scm b/build-aux/hydra/demo-os.scm index 3987c4048..03449abda 100644 --- a/build-aux/hydra/demo-os.scm +++ b/build-aux/hydra/demo-os.scm @@ -48,6 +48,15 @@ (uid 1000) (gid 100) (comment "Guest of GNU") (home-directory "/home/guest")))) + (groups (list (user-group (name "root") (id 0)) + (user-group + (name "wheel") + (id 1) + (members '("guest"))) ; allow 'guest' to use sudo + (user-group + (name "users") + (id 100) + (members '("guest"))))) (services (cons* (slim-service #:auto-login? #t #:default-user "guest") diff --git a/gnu/system.scm b/gnu/system.scm index ba105e2df..6c94eb90c 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -85,11 +85,7 @@ (groups operating-system-groups ; list of user groups (default (list (user-group (name "root") - (id 0)) - (user-group - (name "users") - (id 100) - (members '("guest")))))) + (id 0))))) (packages operating-system-packages ; list of (PACKAGE OUTPUT...) (default (list coreutils ; or just PACKAGE @@ -111,8 +107,10 @@ (pam-services operating-system-pam-services ; list of PAM services (default (base-pam-services))) (setuid-programs operating-system-setuid-programs - (default %setuid-programs))) ; list of string-valued gexps + (default %setuid-programs)) ; list of string-valued gexps + (sudoers operating-system-sudoers ; /etc/sudoers contents + (default %sudoers-specification))) ;;; @@ -164,13 +162,15 @@ file." (accounts '()) (groups '()) (pam-services '()) - (profile "/var/run/current-system/profile")) + (profile "/var/run/current-system/profile") + (sudoers "")) "Return a derivation that builds the static part of the /etc directory." (mlet* %store-monad ((passwd (passwd-file accounts)) (shadow (passwd-file accounts #:shadow? #t)) (group (group-file groups)) (pam.d (pam-services->directory pam-services)) + (sudoers (text-file "sudoers" sudoers)) (login.defs (text-file "login.defs" "# Empty for now.\n")) (shells (text-file "shells" ; used by xterm and others "\ @@ -215,7 +215,9 @@ alias ll='ls -l' #$timezone)) ("passwd" ,#~#$passwd) ("shadow" ,#~#$shadow) - ("group" ,#~#$group))))) + ("group" ,#~#$group) + + ("sudoers" ,#~#$sudoers))))) (define (operating-system-profile os) "Return a derivation that builds the default profile of OS." @@ -254,6 +256,7 @@ alias ll='ls -l' #:pam-services pam-services #:locale (operating-system-locale os) #:timezone (operating-system-timezone os) + #:sudoers (operating-system-sudoers os) #:profile profile-drv))) (define %setuid-programs @@ -261,7 +264,16 @@ alias ll='ls -l' (let ((shadow (@ (gnu packages admin) shadow))) (list #~(string-append #$shadow "/bin/passwd") #~(string-append #$shadow "/bin/su") - #~(string-append #$inetutils "/bin/ping")))) + #~(string-append #$inetutils "/bin/ping") + #~(string-append #$sudo "/bin/sudo")))) + +(define %sudoers-specification + ;; Default /etc/sudoers contents: 'root' and all members of the 'wheel' + ;; group can do anything. See + ;; . + ;; TODO: Add a declarative API. + "root ALL=(ALL) ALL +%wheel ALL=(ALL) ALL\n") (define (operating-system-boot-script os) "Return the boot script for OS---i.e., the code started by the initrd once diff --git a/gnu/system/linux.scm b/gnu/system/linux.scm index 4030d8860..3a43eb45e 100644 --- a/gnu/system/linux.scm +++ b/gnu/system/linux.scm @@ -157,6 +157,8 @@ should be the name of a file used as the message-of-the-day." (list %pam-other-services (unix-pam-service "su" #:allow-empty-passwords? allow-empty-passwords?) (unix-pam-service "passwd" + #:allow-empty-passwords? allow-empty-passwords?) + (unix-pam-service "sudo" #:allow-empty-passwords? allow-empty-passwords?))) ;;; linux.scm ends here -- 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') 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 03ddfaf5fb5fab78f7180089158bea0494072b3c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 3 May 2014 12:16:10 +0200 Subject: vm: Make root file system type a parameter, and default to ext4. * gnu/system/vm.scm (qemu-image): Add #:file-system-type parameter. Pass it to 'initialize-hard-disk'. * guix/build/linux-initrd.scm (mount-root-file-system): Always honor TYPE. (boot-system): Change #:root-fs-type to default to "ext4". Update docstring. * guix/build/vm.scm (initialize-hard-disk): Remove #:mkfs parameter; add #:file-system-type. Adjust 'mkfs' invocation and 'mount' call to honor #:file-system-type. --- gnu/system/vm.scm | 11 +++++++---- guix/build/linux-initrd.scm | 7 +++++-- guix/build/vm.scm | 9 +++++---- 3 files changed, 17 insertions(+), 10 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index c08031741..867e01ad5 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -188,13 +188,15 @@ made available under the /xchg CIFS share." (system (%current-system)) (qemu qemu-headless) (disk-image-size (* 100 (expt 2 20))) + (file-system-type "ext4") grub-configuration (initialize-store? #f) (populate #f) (inputs-to-copy '())) - "Return a bootable, stand-alone QEMU image. The returned image is a full -disk image, with a GRUB installation that uses GRUB-CONFIGURATION as its -configuration file (GRUB-CONFIGURATION must be the name of a file in the VM.) + "Return a bootable, stand-alone QEMU image, with a root partition of type +FILE-SYSTEM-TYPE. The returned image is a full disk image, with a GRUB +installation that uses GRUB-CONFIGURATION as its configuration +file (GRUB-CONFIGURATION must be the name of a file in the VM.) INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied into the image being built. When INITIALIZE-STORE? is true, initialize the @@ -235,6 +237,7 @@ such as /etc files." (initialize-hard-disk #:grub.cfg #$grub-configuration #:closures-to-copy graphs #:disk-image-size #$disk-image-size + #:file-system-type #$file-system-type #:initialize-store? #$initialize-store? #:directives '#$populate) (reboot)))) @@ -315,7 +318,7 @@ environment with the store shared with the host." (file-systems (list (file-system (mount-point "/") (device "/dev/vda1") - (type "ext3")) + (type "ext4")) (file-system (mount-point (%store-prefix)) (device "store") diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 1e0d6e27e..fd6c0c467 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -212,7 +212,7 @@ UNIONFS." "/rw-root=RW:/real-root=RO" "/root")) (error "unionfs failed"))) - (mount root "/root" "ext3"))) + (mount root "/root" type))) (lambda args (format (current-error-port) "exception while mounting '~a': ~s~%" root args) @@ -249,7 +249,7 @@ FLAGS must be a list of symbols." qemu-guest-networking? guile-modules-in-chroot? volatile-root? unionfs - (root-fs-type "ext3") + (root-fs-type "ext4") (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,6 +257,9 @@ 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. + MOUNTS must be a list suitable for 'mount-file-system'. When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in diff --git a/guix/build/vm.scm b/guix/build/vm.scm index 33c898d96..1d1abad1d 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -183,7 +183,7 @@ as created and modified at the Epoch." (define* (initialize-hard-disk #:key grub.cfg disk-image-size - (mkfs "mkfs.ext3") + (file-system-type "ext4") initialize-store? (closures-to-copy '()) (directives '())) @@ -192,13 +192,14 @@ as created and modified at the Epoch." (- disk-image-size (* 5 (expt 2 20)))) (error "failed to create partition table")) - (display "creating ext3 partition...\n") - (unless (zero? (system* mkfs "-F" "/dev/sda1")) + (format #t "creating ~a partition...\n" file-system-type) + (unless (zero? (system* (string-append "mkfs." file-system-type) + "-F" "/dev/sda1")) (error "failed to create partition")) (display "mounting partition...\n") (mkdir "/fs") - (mount "/dev/sda1" "/fs" "ext3") + (mount "/dev/sda1" "/fs" file-system-type) (when (pair? closures-to-copy) ;; Populate the store. -- cgit v1.3 From 66f23d66219533aff689a05d16439827da1a2a59 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 3 May 2014 12:45:43 +0200 Subject: vm: Provide a root partition for the freestanding VM image. Fixes a regression introduced in 83bcd0b. * gnu/system/vm.scm (system-qemu-image): Override the 'file-systems' field of OS. Add #:file-system-type parameter and honor it. --- gnu/system/vm.scm | 35 ++++++++++++++++++++++------------- 1 file changed, 22 insertions(+), 13 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 867e01ad5..786e56403 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -296,19 +296,28 @@ basic contents of the root file system of OS." (operating-system-users os)))))) (define* (system-qemu-image os - #:key (disk-image-size (* 900 (expt 2 20)))) - "Return the derivation of a QEMU image of DISK-IMAGE-SIZE bytes of the GNU -system as described by OS." - (mlet* %store-monad - ((os-drv (operating-system-derivation os)) - (os-dir -> (derivation->output-path os-drv)) - (grub.cfg -> (string-append os-dir "/grub.cfg")) - (populate (operating-system-default-contents os))) - (qemu-image #:grub-configuration grub.cfg - #:populate populate - #:disk-image-size disk-image-size - #:initialize-store? #t - #:inputs-to-copy `(("system" ,os-drv))))) + #:key + (file-system-type "ext4") + (disk-image-size (* 900 (expt 2 20)))) + "Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes +of the GNU system as described by OS." + (let ((os (operating-system (inherit os) + ;; The mounted file systems are under our control. + (file-systems (list (file-system + (mount-point "/") + (device "/dev/sda1") + (type file-system-type))))))) + (mlet* %store-monad + ((os-drv (operating-system-derivation os)) + (os-dir -> (derivation->output-path os-drv)) + (grub.cfg -> (string-append os-dir "/grub.cfg")) + (populate (operating-system-default-contents os))) + (qemu-image #:grub-configuration grub.cfg + #:populate populate + #:disk-image-size disk-image-size + #:file-system-type file-system-type + #: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 -- 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') 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 f3bde2ff9f19a542ccceea40e3750e1e478f245e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 10 May 2014 23:56:45 +0200 Subject: vm: Fix recently-introduced regression in 'operating-system-services' use. * gnu/system/vm.scm (operating-system-build-gid): Adjust to new return type of 'operating-system-services' introduced in 217a5b8. --- gnu/system/vm.scm | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index b20831f44..252085320 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -255,14 +255,14 @@ such as /etc files." (define (operating-system-build-gid os) "Return as a monadic value the group id for build users of OS, or #f." - (anym %store-monad - (lambda (service) - (and (equal? '(guix-daemon) - (service-provision service)) - (match (service-user-groups service) - ((group) - (user-group-id group))))) - (operating-system-services os))) + (mlet %store-monad ((services (operating-system-services os))) + (return (any (lambda (service) + (and (equal? '(guix-daemon) + (service-provision service)) + (match (service-user-groups service) + ((group) + (user-group-id group))))) + services)))) (define (operating-system-default-contents os) "Return a list of directives suitable for 'system-qemu-image' describing the -- cgit v1.3 From ab6a279abbfa39b1e1bec0e363744d241972f844 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 11 May 2014 22:41:01 +0200 Subject: system: Make accounts and groups at activation time. * gnu/services/base.scm (guix-build-accounts): Remove #:gid parameter; add #:group. Remove 'password' and 'gid' fields in 'user-account' form, and add 'group'. (guix-service): Remove #:build-user-gid parameter. Remove 'id' field in 'user-group' form. * gnu/system.scm (etc-directory): Remove #:groups and #:accounts. No longer produce files "passwd", "shadow", and "group". Adjust caller accordingly. (%root-account): New variable. (operating-system-accounts): Add 'users' variable. Add %ROOT-ACCOUNT only of 'operating-system-users' doesn't already contain a root account. (user-group->gexp, user-account->gexp): New procedures. (operating-system-boot-script): Add calls to 'setenv' and 'activate-users+groups' in gexp. * gnu/system/linux.scm (base-pam-services): Add PAM services for "user{add,del,mode}" and "group{add,del,mod}". * gnu/system/shadow.scm ()[gid]: Rename to... [group]: ... this. [supplementary-groups]: New field. [uid, password]: Default to #f. ()[id]: Default to #f. (group-file, passwd-file): Remove. * gnu/system/vm.scm (operating-system-default-contents)[user-directories]: Remove. Add "/home" to the directives. * guix/build/activation.scm (add-group, add-user, activate-users+groups): New procedures. --- build-aux/hydra/demo-os.scm | 3 +- gnu/services/base.scm | 10 ++--- gnu/system.scm | 95 +++++++++++++++++++++++++++++--------------- gnu/system/linux.scm | 14 ++++--- gnu/system/shadow.scm | 61 +++++----------------------- gnu/system/vm.scm | 15 +------ guix/build/activation.scm | 97 ++++++++++++++++++++++++++++++++++++++++++++- 7 files changed, 186 insertions(+), 109 deletions(-) (limited to 'gnu/system') diff --git a/build-aux/hydra/demo-os.scm b/build-aux/hydra/demo-os.scm index 03449abda..4116c063f 100644 --- a/build-aux/hydra/demo-os.scm +++ b/build-aux/hydra/demo-os.scm @@ -45,7 +45,8 @@ (locale "en_US.UTF-8") (users (list (user-account (name "guest") - (uid 1000) (gid 100) + (group "wheel") + (password "") (comment "Guest of GNU") (home-directory "/home/guest")))) (groups (list (user-group (name "root") (id 0)) diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 6431a3aab..1f5ff3e4c 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -237,8 +237,8 @@ stopped before 'kill' is called." (stop #~(make-kill-destructor)))))) (define* (guix-build-accounts count #:key + (group "guixbuild") (first-uid 30001) - (gid 30000) (shadow shadow)) "Return a list of COUNT user accounts for Guix build users, with UIDs starting at FIRST-UID, and under GID." @@ -247,9 +247,8 @@ starting at FIRST-UID, and under GID." (lambda (n) (user-account (name (format #f "guixbuilder~2,'0d" n)) - (password "!") (uid (+ first-uid n -1)) - (gid gid) + (group group) (comment (format #f "Guix Build User ~2d" n)) (home-directory "/var/empty") (shell #~(string-append #$shadow "/sbin/nologin")))) @@ -257,11 +256,11 @@ starting at FIRST-UID, and under GID." 1)))) (define* (guix-service #:key (guix guix) (builder-group "guixbuild") - (build-user-gid 30000) (build-accounts 10)) + (build-accounts 10)) "Return a service that runs the build daemon from GUIX, and has BUILD-ACCOUNTS user accounts available under BUILD-USER-GID." (mlet %store-monad ((accounts (guix-build-accounts build-accounts - #:gid build-user-gid))) + #:group builder-group))) (return (service (provision '(guix-daemon)) (requirement '(user-processes)) @@ -274,7 +273,6 @@ BUILD-ACCOUNTS user accounts available under BUILD-USER-GID." (user-accounts accounts) (user-groups (list (user-group (name builder-group) - (id build-user-gid) (members (map user-account-name user-accounts))))))))) diff --git a/gnu/system.scm b/gnu/system.scm index d76c3670f..bd69532a8 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -224,17 +224,12 @@ explicitly appear in OS." (define* (etc-directory #:key (locale "C") (timezone "Europe/Paris") - (accounts '()) - (groups '()) (pam-services '()) (profile "/var/run/current-system/profile") (sudoers "")) "Return a derivation that builds the static part of the /etc directory." (mlet* %store-monad - ((passwd (passwd-file accounts)) - (shadow (passwd-file accounts #:shadow? #t)) - (group (group-file groups)) - (pam.d (pam-services->directory pam-services)) + ((pam.d (pam-services->directory pam-services)) (sudoers (text-file "sudoers" sudoers)) (login.defs (text-file "login.defs" "# Empty for now.\n")) (shells (text-file "shells" ; used by xterm and others @@ -278,10 +273,6 @@ alias ll='ls -l' ("profile" ,#~#$bashrc) ("localtime" ,#~(string-append #$tzdata "/share/zoneinfo/" #$timezone)) - ("passwd" ,#~#$passwd) - ("shadow" ,#~#$shadow) - ("group" ,#~#$group) - ("sudoers" ,#~#$sudoers))))) (define (operating-system-profile os) @@ -290,18 +281,28 @@ alias ll='ls -l' (union (operating-system-packages os) #:name "default-profile")) +(define %root-account + ;; Default root account. + (user-account + (name "root") + (password "") + (uid 0) (group "root") + (comment "System administrator") + (home-directory "/root"))) + (define (operating-system-accounts os) "Return the user accounts for OS, including an obligatory 'root' account." + (define users + ;; Make sure there's a root account. + (if (find (lambda (user) + (and=> (user-account-uid user) zero?)) + (operating-system-users os)) + (operating-system-users os) + (cons %root-account (operating-system-users os)))) + (mlet %store-monad ((services (operating-system-services os))) - (return (cons (user-account - (name "root") - (password "") - (uid 0) (gid 0) - (comment "System administrator") - (home-directory "/root")) - (append (operating-system-users os) - (append-map service-user-accounts - services)))))) + (return (append users + (append-map service-user-accounts services))))) (define (operating-system-etc-directory os) "Return that static part of the /etc directory of OS." @@ -312,12 +313,8 @@ alias ll='ls -l' (delete-duplicates (append (operating-system-pam-services os) (append-map service-pam-services services)))) - (accounts (operating-system-accounts os)) - (profile-drv (operating-system-profile os)) - (groups -> (append (operating-system-groups os) - (append-map service-user-groups services)))) - (etc-directory #:accounts accounts #:groups groups - #:pam-services pam-services + (profile-drv (operating-system-profile os))) + (etc-directory #:pam-services pam-services #:locale (operating-system-locale os) #:timezone (operating-system-timezone os) #:sudoers (operating-system-sudoers os) @@ -339,6 +336,25 @@ alias ll='ls -l' "root ALL=(ALL) ALL %wheel ALL=(ALL) ALL\n") +(define (user-group->gexp group) + "Turn GROUP, a object, into a list-valued gexp suitable for +'active-groups'." + #~(list #$(user-group-name group) + #$(user-group-password group) + #$(user-group-id group))) + +(define (user-account->gexp account) + "Turn ACCOUNT, a object, into a list-valued gexp suitable for +'activate-users'." + #~`(#$(user-account-name account) + #$(user-account-uid account) + #$(user-account-group account) + #$(user-account-supplementary-groups account) + #$(user-account-comment account) + #$(user-account-home-directory account) + ,#$(user-account-shell account) ; this one is a gexp + #$(user-account-password account))) + (define (operating-system-boot-script os) "Return the boot script for OS---i.e., the code started by the initrd once we're running in the final root." @@ -346,15 +362,25 @@ we're running in the final root." '((guix build activation) (guix build utils))) - (mlet* %store-monad - ((services (operating-system-services os)) - (etc (operating-system-etc-directory os)) - (modules (imported-modules %modules)) - (compiled (compiled-modules %modules)) - (dmd-conf (dmd-configuration-file services))) + (mlet* %store-monad ((services (operating-system-services os)) + (etc (operating-system-etc-directory os)) + (modules (imported-modules %modules)) + (compiled (compiled-modules %modules)) + (dmd-conf (dmd-configuration-file services)) + (accounts (operating-system-accounts os))) (define setuid-progs (operating-system-setuid-programs os)) + (define user-specs + (map user-account->gexp accounts)) + + (define groups + (append (operating-system-groups os) + (append-map service-user-groups services))) + + (define group-specs + (map user-group->gexp groups)) + (gexp->file "boot" #~(begin (eval-when (expand load eval) @@ -368,6 +394,13 @@ we're running in the final root." ;; Populate /etc. (activate-etc #$etc) + ;; Add users and user groups. + (setenv "PATH" + (string-append #$(@ (gnu packages admin) shadow) + "/sbin")) + (activate-users+groups (list #$@user-specs) + (list #$@group-specs)) + ;; Activate setuid programs. (activate-setuid-programs (list #$@setuid-progs)) diff --git a/gnu/system/linux.scm b/gnu/system/linux.scm index 3a43eb45e..5440f5852 100644 --- a/gnu/system/linux.scm +++ b/gnu/system/linux.scm @@ -154,11 +154,13 @@ should be the name of a file used as the message-of-the-day." (define* (base-pam-services #:key allow-empty-passwords?) "Return the list of basic PAM services everyone would want." - (list %pam-other-services - (unix-pam-service "su" #:allow-empty-passwords? allow-empty-passwords?) - (unix-pam-service "passwd" - #:allow-empty-passwords? allow-empty-passwords?) - (unix-pam-service "sudo" - #:allow-empty-passwords? allow-empty-passwords?))) + (cons %pam-other-services + (map (cut unix-pam-service <> + #:allow-empty-passwords? allow-empty-passwords?) + '("su" "passwd" "sudo" + "useradd" "userdel" "usermod" + "groupadd" "groupdel" "groupmod" + ;; TODO: Add other Shadow programs? + )))) ;;; linux.scm ends here diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index 52242ee4e..8745ddb87 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -30,9 +30,10 @@ #:export (user-account user-account? user-account-name - user-account-pass + user-account-password user-account-uid - user-account-gid + user-account-group + user-account-supplementary-groups user-account-comment user-account-home-directory user-account-shell @@ -42,11 +43,7 @@ user-group-name user-group-password user-group-id - user-group-members - - passwd-file - group-file - guix-build-accounts)) + user-group-members)) ;;; Commentary: ;;; @@ -58,9 +55,11 @@ user-account make-user-account user-account? (name user-account-name) - (password user-account-pass (default "")) - (uid user-account-uid) - (gid user-account-gid) + (password user-account-password (default #f)) + (uid user-account-uid (default #f)) + (group user-account-group) ; number | string + (supplementary-groups user-account-supplementary-groups + (default '())) ; list of strings (comment user-account-comment (default "")) (home-directory user-account-home-directory) (shell user-account-shell ; gexp @@ -71,47 +70,7 @@ user-group? (name user-group-name) (password user-group-password (default #f)) - (id user-group-id) + (id user-group-id (default #f)) (members user-group-members (default '()))) -(define (group-file groups) - "Return a /etc/group file for GROUPS, a list of objects." - (define contents - (let loop ((groups groups) - (result '())) - (match groups - ((($ name _ gid (users ...)) rest ...) - ;; XXX: Ignore the group password. - (loop rest - (cons (string-append name "::" (number->string gid) - ":" (string-join users ",")) - result))) - (() - (string-join (reverse result) "\n" 'suffix))))) - - (text-file "group" contents)) - -(define* (passwd-file accounts #:key shadow?) - "Return a password file for ACCOUNTS, a list of objects. If -SHADOW? is true, then it is a /etc/shadow file, otherwise it is a /etc/passwd -file." - ;; XXX: The resulting file is world-readable, so beware when SHADOW? is #t! - (define account-exp - (match-lambda - (($ name pass uid gid comment home-dir shell) - (if shadow? ; XXX: use (crypt PASS …)? - #~(format #t "~a::::::::~%" #$name) - #~(format #t "~a:x:~a:~a:~a:~a:~a~%" - #$name #$(number->string uid) #$(number->string gid) - #$comment #$home-dir #$shell))))) - - (define builder - #~(begin - (with-output-to-file #$output - (lambda () - #$@(map account-exp accounts) - #t)))) - - (gexp->derivation (if shadow? "shadow" "passwd") builder)) - ;;; shadow.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 252085320..ede7ea772 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -267,16 +267,6 @@ such as /etc files." (define (operating-system-default-contents os) "Return a list of directives suitable for 'system-qemu-image' describing the basic contents of the root file system of OS." - (define (user-directories user) - (let ((home (user-account-home-directory user)) - ;; XXX: Deal with automatically allocated ids. - (uid (or (user-account-uid user) 0)) - (gid (or (user-account-gid user) 0)) - (root (string-append "/var/guix/profiles/per-user/" - (user-account-name user)))) - #~((directory #$root #$uid #$gid) - (directory #$home #$uid #$gid)))) - (mlet* %store-monad ((os-drv (operating-system-derivation os)) (build-gid (operating-system-build-gid os)) (profile (operating-system-profile os))) @@ -293,9 +283,8 @@ basic contents of the root file system of OS." (directory "/tmp") (directory "/var/guix/profiles/per-user/root" 0 0) - (directory "/root" 0 0) ; an exception - #$@(append-map user-directories - (operating-system-users os)))))) + (directory "/root" 0 0) ; an exception + (directory "/home" 0 0))))) (define* (system-qemu-image os #:key diff --git a/guix/build/activation.scm b/guix/build/activation.scm index f9d9ba5cb..895f2bca5 100644 --- a/guix/build/activation.scm +++ b/guix/build/activation.scm @@ -19,8 +19,11 @@ (define-module (guix build activation) #:use-module (guix build utils) #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) - #:export (activate-etc + #:export (activate-users+groups + activate-etc activate-setuid-programs)) ;;; Commentary: @@ -31,6 +34,98 @@ ;;; ;;; Code: +(define* (add-group name #:key gid password + (log-port (current-error-port))) + "Add NAME as a user group, with the given numeric GID if specified." + ;; Use 'groupadd' from the Shadow package. + (format log-port "adding group '~a'...~%" name) + (let ((args `(,@(if gid `("-g" ,(number->string gid)) '()) + ,@(if password `("-p" ,password) '()) + ,name))) + (zero? (apply system* "groupadd" args)))) + +(define* (add-user name group + #:key uid comment home shell password + (supplementary-groups '()) + (log-port (current-error-port))) + "Create an account for user NAME part of GROUP, with the specified +properties. Return #t on success." + (format log-port "adding user '~a'...~%" name) + + (if (and uid (zero? uid)) + + ;; 'useradd' fails with "Cannot determine your user name" if the root + ;; account doesn't exist. Thus, for bootstrapping purposes, create that + ;; one manually. + (begin + (call-with-output-file "/etc/shadow" + (cut format <> "~a::::::::~%" name)) + (call-with-output-file "/etc/passwd" + (cut format <> "~a:x:~a:~a:~a:~a:~a~%" + name "0" "0" comment home shell)) + (chmod "/etc/shadow" #o600) + #t) + + ;; Use 'useradd' from the Shadow package. + (let ((args `(,@(if uid `("-u" ,(number->string uid)) '()) + "-g" ,(if (number? group) (number->string group) group) + ,@(if (pair? supplementary-groups) + `("-G" ,(string-join supplementary-groups ",")) + '()) + ,@(if comment `("-c" ,comment) '()) + ,@(if home `("-d" ,home "--create-home") '()) + ,@(if shell `("-s" ,shell) '()) + ,@(if password `("-p" ,password) '()) + ,name))) + (zero? (apply system* "useradd" args))))) + +(define (activate-users+groups users groups) + "Make sure the accounts listed in USERS and the user groups listed in GROUPS +are all available. + +Each item in USERS is a list of all the characteristics of a user account; +each item in GROUPS is a tuple with the group name, group password or #f, and +numeric gid or #f." + (define (touch file) + (call-with-output-file file (const #t))) + + (define activate-user + (match-lambda + ((name uid group supplementary-groups comment home shell password) + (unless (false-if-exception (getpwnam name)) + (let ((profile-dir (string-append "/var/guix/profiles/per-user/" + name))) + (add-user name group + #:uid uid + #:supplementary-groups supplementary-groups + #:comment comment + #:home home + #:shell shell + #:password password) + + ;; Create the profile directory for the new account. + (let ((pw (getpwnam name))) + (mkdir-p profile-dir) + (chown profile-dir (passwd:uid pw) (passwd:gid pw)))))))) + + ;; 'groupadd' aborts if the file doesn't already exist. + (touch "/etc/group") + + ;; Create the root account so we can use 'useradd' and 'groupadd'. + (activate-user (find (match-lambda + ((name (? zero?) _ ...) #t) + (_ #f)) + users)) + + ;; Then create the groups. + (for-each (match-lambda + ((name password gid) + (add-group name #:gid gid #:password password))) + groups) + + ;; Finally create the other user accounts. + (for-each activate-user users)) + (define (activate-etc etc) "Install ETC, a directory in the store, as the source of static files for /etc." -- cgit v1.3 From 838d9a9ddb3186e587adfa7329c7e577d766001d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 13 May 2014 21:32:48 +0200 Subject: system: Move skeleton code to (gnu system shadow). * gnu/system.scm (default-skeletons, skeleton-directory): Move to... * gnu/system/shadow.scm: ... here. --- gnu/system.scm | 45 ------------------------------------------ gnu/system/shadow.scm | 54 ++++++++++++++++++++++++++++++++++++++++++++++----- 2 files changed, 49 insertions(+), 50 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system.scm b/gnu/system.scm index fae8fe44a..f78df7ce1 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -26,7 +26,6 @@ #:use-module (gnu packages base) #:use-module (gnu packages bash) #:use-module (gnu packages admin) - #:use-module (gnu packages guile-wm) #:use-module (gnu packages package-management) #:use-module (gnu services) #:use-module (gnu services dmd) @@ -236,50 +235,6 @@ explicitly appear in OS." ;;; /etc. ;;; -(define (default-skeletons) - "Return the default skeleton files for /etc/skel. These files are copied by -'useradd' in the home directory of newly created user accounts." - (define copy-guile-wm - #~(begin - (use-modules (guix build utils)) - (copy-file (car (find-files #$guile-wm "wm-init-sample.scm")) - #$output))) - - (mlet %store-monad ((bashrc (text-file "bashrc" "\ -# Allow non-login shells such as an xterm to get things right. -test -f /etc/profile && source /etc/profile\n")) - (guile-wm (gexp->derivation "guile-wm" copy-guile-wm - #:modules - '((guix build utils)))) - (xdefaults (text-file "Xdefaults" "\ -XTerm*utf8: always -XTerm*metaSendsEscape: true\n")) - (gdbinit (text-file "gdbinit" "\ -# Tell GDB where to look for separate debugging files. -set debug-file-directory ~/.guix-profile/lib/debug\n"))) - (return `((".bashrc" ,bashrc) - (".Xdefaults" ,xdefaults) - (".guile-wm" ,guile-wm) - (".gdbinit" ,gdbinit))))) - -(define (skeleton-directory skeletons) - "Return a directory containing SKELETONS, a list of name/derivation pairs." - (gexp->derivation "skel" - #~(begin - (use-modules (ice-9 match)) - - (mkdir #$output) - (chdir #$output) - - ;; Note: copy the skeletons instead of symlinking - ;; them like 'file-union' does, because 'useradd' - ;; would just copy the symlinks as is. - (for-each (match-lambda - ((target source) - (copy-file source target))) - '#$skeletons) - #t))) - (define* (etc-directory #:key (locale "C") (timezone "Europe/Paris") (skeletons '()) diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index 8745ddb87..738816b78 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -17,16 +17,13 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu system shadow) - #:use-module (guix store) #:use-module (guix records) - #:use-module (guix packages) #:use-module (guix gexp) #:use-module (guix monads) #:use-module ((gnu packages admin) #:select (shadow)) #:use-module (gnu packages bash) - #:use-module (srfi srfi-1) - #:use-module (ice-9 match) + #:use-module (gnu packages guile-wm) #:export (user-account user-account? user-account-name @@ -43,7 +40,10 @@ user-group-name user-group-password user-group-id - user-group-members)) + user-group-members + + default-skeletons + skeleton-directory)) ;;; Commentary: ;;; @@ -73,4 +73,48 @@ (id user-group-id (default #f)) (members user-group-members (default '()))) +(define (default-skeletons) + "Return the default skeleton files for /etc/skel. These files are copied by +'useradd' in the home directory of newly created user accounts." + (define copy-guile-wm + #~(begin + (use-modules (guix build utils)) + (copy-file (car (find-files #$guile-wm "wm-init-sample.scm")) + #$output))) + + (mlet %store-monad ((bashrc (text-file "bashrc" "\ +# Allow non-login shells such as an xterm to get things right. +test -f /etc/profile && source /etc/profile\n")) + (guile-wm (gexp->derivation "guile-wm" copy-guile-wm + #:modules + '((guix build utils)))) + (xdefaults (text-file "Xdefaults" "\ +XTerm*utf8: always +XTerm*metaSendsEscape: true\n")) + (gdbinit (text-file "gdbinit" "\ +# Tell GDB where to look for separate debugging files. +set debug-file-directory ~/.guix-profile/lib/debug\n"))) + (return `((".bashrc" ,bashrc) + (".Xdefaults" ,xdefaults) + (".guile-wm" ,guile-wm) + (".gdbinit" ,gdbinit))))) + +(define (skeleton-directory skeletons) + "Return a directory containing SKELETONS, a list of name/derivation pairs." + (gexp->derivation "skel" + #~(begin + (use-modules (ice-9 match)) + + (mkdir #$output) + (chdir #$output) + + ;; Note: copy the skeletons instead of symlinking + ;; them like 'file-union' does, because 'useradd' + ;; would just copy the symlinks as is. + (for-each (match-lambda + ((target source) + (copy-file source target))) + '#$skeletons) + #t))) + ;;; shadow.scm ends here -- cgit v1.3 From 5a84a6c3146bd0ea8e5cbccfee2f6c9f302c25e0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 13 May 2014 23:56:24 +0200 Subject: vm: Pass '-serial stdio' in the run-vm.sh. * gnu/system/vm.scm (system-qemu-image/shared-store-script): Add '-serial stdio'. --- gnu/system/vm.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index ede7ea772..c6c23213c 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -365,6 +365,7 @@ exec " #$qemu "/bin/qemu-system-x86_64 -enable-kvm -no-reboot -net nic,model=vir -initrd " #$os-drv "/initrd \ -append \"" #$(if graphic? "" "console=ttyS0 ") "--load=" #$os-drv "/boot --root=/dev/vda1\" \ + -serial stdio \ -drive file=" #$image ",if=virtio,cache=writeback,werror=report,readonly\n") port) -- cgit v1.3 From 1eeccc2f31c0b0f8c600cb181f19fda1d90551a6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 14 May 2014 23:15:51 +0200 Subject: vm: Keep acceptable file systems from the original OS. * gnu/system/vm.scm (virtualized-operating-system): Instead of completely overriding 'file-systems', use 'remove' to filter out some of those declared in OS. (system-qemu-image): Likewise. --- gnu/system/vm.scm | 49 +++++++++++++++++++++++++++++++++++-------------- 1 file changed, 35 insertions(+), 14 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index c6c23213c..f42feb394 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -292,12 +292,23 @@ basic contents of the root file system of OS." (disk-image-size (* 900 (expt 2 20)))) "Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes of the GNU system as described by OS." + (define file-systems-to-keep + ;; Keep only file systems other than root and not normally bound to real + ;; devices. + (remove (lambda (fs) + (let ((target (file-system-mount-point fs)) + (source (file-system-device fs))) + (or (string=? target "/") + (string-prefix? "/dev/" source)))) + (operating-system-file-systems os))) + (let ((os (operating-system (inherit os) - ;; The mounted file systems are under our control. - (file-systems (list (file-system + ;; Force our own root file system. + (file-systems (cons (file-system (mount-point "/") (device "/dev/sda1") - (type file-system-type))))))) + (type file-system-type)) + file-systems-to-keep))))) (mlet* %store-monad ((os-drv (operating-system-derivation os)) (os-dir -> (derivation->output-path os-drv)) @@ -315,17 +326,27 @@ of the GNU system as described by OS." 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 "ext4")) - (file-system - (mount-point (%store-prefix)) - (device "store") - (type "9p") - (needed-for-boot? #t) - (options "trans=virtio") - (check? #f)))))) + (file-systems (cons* (file-system + (mount-point "/") + (device "/dev/vda1") + (type "ext4")) + (file-system + (mount-point (%store-prefix)) + (device "store") + (type "9p") + (needed-for-boot? #t) + (options "trans=virtio") + (check? #f)) + + ;; Remove file systems that conflict with those + ;; above, or that are normally bound to real devices. + (remove (lambda (fs) + (let ((target (file-system-mount-point fs)) + (source (file-system-device fs))) + (or (string=? target (%store-prefix)) + (string=? target "/") + (string-prefix? "/dev/" source)))) + (operating-system-file-systems os)))))) (define* (system-qemu-image/shared-store os -- cgit v1.3 From 150e20ddde726abdfe77fa666351738cccb06281 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 15 May 2014 22:55:14 +0200 Subject: vm: Support initialization of the store DB when the store is shared. * gnu/system/vm.scm (qemu-image): Rename #:inputs-to-copy to #:inputs, and #:initialize-store? to #:register-closures?. Add #:copy-inputs?. Adjust build gexp accordingly. (system-qemu-image): Remove #:initialize-store? argument and add #:copy-inputs?. (system-qemu-image/shared-store): Add #:inputs, #:register-closures?, and #:copy-inputs? arguments. * guix/build/vm.scm (register-closure): New procedure. (MS_BIND): New variable. (initialize-hard-disk): Rename #:initialize-store? to #:register-closures?, #:closures-to-copy to #:closures, and add #:copy-closures?. Add 'target-directory' and 'target-store' variables. Call 'populate-store' only when COPY-CLOSURES?. Bind-mount the store to TARGET-STORE when REGISTER-CLOSURES? and not COPY-CLOSURES?. Add call to 'register-closure'. --- gnu/system/vm.scm | 40 ++++++++++++++++++-------------- guix/build/vm.scm | 68 +++++++++++++++++++++++++++++++++++++++---------------- 2 files changed, 72 insertions(+), 36 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index f42feb394..7008c5dab 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -192,25 +192,26 @@ made available under the /xchg CIFS share." (disk-image-size (* 100 (expt 2 20))) (file-system-type "ext4") grub-configuration - (initialize-store? #f) + (register-closures? #t) (populate #f) - (inputs-to-copy '())) + (inputs '()) + copy-inputs?) "Return a bootable, stand-alone QEMU image, with a root partition of type FILE-SYSTEM-TYPE. The returned image is a full disk image, with a GRUB installation that uses GRUB-CONFIGURATION as its configuration file (GRUB-CONFIGURATION must be the name of a file in the VM.) -INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied -into the image being built. When INITIALIZE-STORE? is true, initialize the -store database in the image so that Guix can be used in the image. +INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy +all of INPUTS into the image being built. When REGISTER-CLOSURES? is true, +register INPUTS in the store database of the image so that Guix can be used in +the image. POPULATE is a list of directives stating directories or symlinks to be created in the disk image partition. It is evaluated once the image has been populated with INPUTS-TO-COPY. It can be used to provide additional files, such as /etc files." (mlet %store-monad - ((graph (sequence %store-monad - (map input->name+output inputs-to-copy)))) + ((graph (sequence %store-monad (map input->name+output inputs)))) (expression->derivation-in-linux-vm name #~(begin @@ -221,26 +222,27 @@ such as /etc files." '#$(append (list qemu parted grub e2fsprogs util-linux) (map (compose car (cut assoc-ref %final-inputs <>)) '("sed" "grep" "coreutils" "findutils" "gawk")) - (if initialize-store? (list guix) '()))) + (if register-closures? (list guix) '()))) ;; This variable is unused but allows us to add INPUTS-TO-COPY ;; as inputs. - (to-copy + (to-register '#$(map (match-lambda ((name thing) thing) ((name thing output) `(,thing ,output))) - inputs-to-copy))) + inputs))) (set-path-environment-variable "PATH" '("bin" "sbin") inputs) - (let ((graphs '#$(match inputs-to-copy + (let ((graphs '#$(match inputs (((names . _) ...) names)))) (initialize-hard-disk #:grub.cfg #$grub-configuration - #:closures-to-copy graphs + #:closures graphs + #:copy-closures? #$copy-inputs? + #:register-closures? #$register-closures? #:disk-image-size #$disk-image-size #:file-system-type #$file-system-type - #:initialize-store? #$initialize-store? #:directives '#$populate) (reboot)))) #:system system @@ -318,8 +320,8 @@ of the GNU system as described by OS." #:populate populate #:disk-image-size disk-image-size #:file-system-type file-system-type - #:initialize-store? #t - #:inputs-to-copy `(("system" ,os-drv)))))) + #:inputs `(("system" ,os-drv)) + #:copy-inputs? #t)))) (define (virtualized-operating-system os) "Return an operating system based on OS suitable for use in a virtualized @@ -358,10 +360,14 @@ with the host." (os-dir -> (derivation->output-path os-drv)) (grub.cfg -> (string-append os-dir "/grub.cfg")) (populate (operating-system-default-contents os))) - ;; TODO: Initialize the database so Guix can be used in the guest. (qemu-image #:grub-configuration grub.cfg #:populate populate - #:disk-image-size disk-image-size))) + #:disk-image-size disk-image-size + #:inputs `(("system" ,os-drv)) + + ;; XXX: Passing #t here is too slow, so let it off by default. + #:register-closures? #f + #:copy-inputs? #f))) (define* (system-qemu-image/shared-store-script os diff --git a/guix/build/vm.scm b/guix/build/vm.scm index 1d1abad1d..2c13a8904 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -180,13 +180,36 @@ as created and modified at the Epoch." (utime file 0 0 0 0)))) (find-files directory ""))) +(define (register-closure store closure) + "Register CLOSURE in STORE, where STORE is the directory name of the target +store and CLOSURE is the name of a file containing a reference graph as used +by 'guix-register'." + (let ((status (system* "guix-register" "--prefix" store + closure))) + (unless (zero? status) + (error "failed to register store items" closure)))) + +(define MS_BIND 4096) ; again! + (define* (initialize-hard-disk #:key grub.cfg disk-image-size (file-system-type "ext4") - initialize-store? - (closures-to-copy '()) + (closures '()) + copy-closures? + (register-closures? #t) (directives '())) + "Initialize /dev/sda, a disk of DISK-IMAGE-SIZE bytes, with a +FILE-SYSTEM-TYPE partition, and with GRUB installed. If REGISTER-CLOSURES? is +true, register all of CLOSURES is the partition's store. If COPY-CLOSURES? is +true, copy all of CLOSURES to the partition. Lastly, apply DIRECTIVES to +further populate the partition." + (define target-directory + "/fs") + + (define target-store + (string-append target-directory (%store-directory))) + (unless (initialize-partition-table "/dev/sda" #:partition-size (- disk-image-size (* 5 (expt 2 20)))) @@ -198,36 +221,43 @@ as created and modified at the Epoch." (error "failed to create partition")) (display "mounting partition...\n") - (mkdir "/fs") - (mount "/dev/sda1" "/fs" file-system-type) + (mkdir target-directory) + (mount "/dev/sda1" target-directory file-system-type) - (when (pair? closures-to-copy) + (when copy-closures? ;; Populate the store. - (populate-store (map (cut string-append "/xchg/" <>) - closures-to-copy) - "/fs")) + (populate-store (map (cut string-append "/xchg/" <>) closures) + target-directory)) ;; Populate /dev. - (make-essential-device-nodes #:root "/fs") + (make-essential-device-nodes #:root target-directory) ;; Optionally, register the inputs in the image's store. - (when initialize-store? + (when register-closures? + (unless copy-closures? + ;; XXX: 'guix-register' wants to palpate the things it registers, so + ;; bind-mount the store on the target. + (mkdir-p target-store) + (mount (%store-directory) target-store "" MS_BIND)) + + (display "registering closures...\n") (for-each (lambda (closure) - (let ((status (system* "guix-register" "--prefix" "/fs" - (string-append "/xchg/" closure)))) - (unless (zero? status) - (error "failed to register store items" closure)))) - closures-to-copy)) + (register-closure target-directory + (string-append "/xchg/" closure))) + closures) + (unless copy-closures? + (system* "umount" target-store))) ;; Evaluate the POPULATE directives. - (for-each (cut evaluate-populate-directive <> "/fs") + (display "populating...\n") + (for-each (cut evaluate-populate-directive <> target-directory) directives) - (unless (install-grub grub.cfg "/dev/sda" "/fs") + (unless (install-grub grub.cfg "/dev/sda" target-directory) (error "failed to install GRUB")) - (reset-timestamps "/fs") + (reset-timestamps target-directory) - (zero? (system* "umount" "/fs"))) + (zero? (system* "umount" target-directory))) ;;; vm.scm ends here -- cgit v1.3 From 5ce3defed18c204989dceed64d3434ed9f3f1a92 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 15 May 2014 23:37:46 +0200 Subject: system: Add (guix build install) module. * guix/build/vm.scm (install-grub, evaluate-populate-directive, reset-timestamps, register-closure): Move to... * guix/build/install.scm: ... here. New file. * Makefile.am (MODULES): Add it. * gnu/system/vm.scm (expression->derivation-in-linux-vm): Add (guix build install) to #:modules. --- Makefile.am | 1 + gnu/system/vm.scm | 5 ++- guix/build/install.scm | 82 ++++++++++++++++++++++++++++++++++++++++++++++++++ guix/build/vm.scm | 46 +--------------------------- 4 files changed, 86 insertions(+), 48 deletions(-) create mode 100644 guix/build/install.scm (limited to 'gnu/system') diff --git a/Makefile.am b/Makefile.am index 20bf650c9..a08215ef1 100644 --- a/Makefile.am +++ b/Makefile.am @@ -70,6 +70,7 @@ MODULES = \ guix/build/rpath.scm \ guix/build/svn.scm \ guix/build/vm.scm \ + guix/build/install.scm \ guix/build/activation.scm \ guix/build/syscalls.scm \ guix/packages.scm \ diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 7008c5dab..58e5416b3 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -109,6 +109,7 @@ input tuple. The output file name is when building for SYSTEM." (env-vars '()) (modules '((guix build vm) + (guix build install) (guix build linux-initrd) (guix build utils))) (guile-for-build @@ -179,9 +180,7 @@ made available under the /xchg CIFS share." ;; TODO: Require the "kvm" feature. #:system system #:env-vars env-vars - #:modules `((guix build utils) - (guix build vm) - (guix build linux-initrd)) + #:modules modules #:guile-for-build guile-for-build #:references-graphs references-graphs))) diff --git a/guix/build/install.scm b/guix/build/install.scm new file mode 100644 index 000000000..37153703e --- /dev/null +++ b/guix/build/install.scm @@ -0,0 +1,82 @@ +;;; 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 (guix build install) + #:use-module (guix build utils) + #:use-module (guix build install) + #:use-module (ice-9 match) + #:export (install-grub + evaluate-populate-directive + reset-timestamps + register-closure)) + +;;; Commentary: +;;; +;;; This module supports the installation of the GNU system on a hard disk. +;;; It is meant to be used both in a build environment (in derivations that +;;; build VM images), and on the bare metal (when really installing the +;;; system.) +;;; +;;; Code: + +(define* (install-grub grub.cfg device mount-point) + "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on +MOUNT-POINT. Return #t on success." + (mkdir-p (string-append mount-point "/boot/grub")) + (symlink grub.cfg (string-append mount-point "/boot/grub/grub.cfg")) + (zero? (system* "grub-install" "--no-floppy" + "--boot-directory" (string-append mount-point "/boot") + device))) + +(define (evaluate-populate-directive directive target) + "Evaluate DIRECTIVE, an sexp describing a file or directory to create under +directory TARGET." + (match directive + (('directory name) + (mkdir-p (string-append target name))) + (('directory name uid gid) + (let ((dir (string-append target name))) + (mkdir-p dir) + (chown dir uid gid))) + ((new '-> old) + (symlink old (string-append target new))))) + +(define (reset-timestamps directory) + "Reset the timestamps of all the files under DIRECTORY, so that they appear +as created and modified at the Epoch." + (display "clearing file timestamps...\n") + (for-each (lambda (file) + (let ((s (lstat file))) + ;; XXX: Guile uses libc's 'utime' function (not 'futime'), so + ;; the timestamp of symlinks cannot be changed, and there are + ;; symlinks here pointing to /gnu/store, which is the host, + ;; read-only store. + (unless (eq? (stat:type s) 'symlink) + (utime file 0 0 0 0)))) + (find-files directory ""))) + +(define (register-closure store closure) + "Register CLOSURE in STORE, where STORE is the directory name of the target +store and CLOSURE is the name of a file containing a reference graph as used +by 'guix-register'." + (let ((status (system* "guix-register" "--prefix" store + closure))) + (unless (zero? status) + (error "failed to register store items" closure)))) + +;;; install.scm ends here diff --git a/guix/build/vm.scm b/guix/build/vm.scm index 2c13a8904..12f952bd1 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -19,6 +19,7 @@ (define-module (guix build vm) #:use-module (guix build utils) #:use-module (guix build linux-initrd) + #:use-module (guix build install) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) #:use-module (srfi srfi-1) @@ -124,15 +125,6 @@ partition of PARTITION-SIZE MiB. Return #t on success." "mkpart" "primary" "ext2" "1MiB" (format #f "~aB" partition-size)))) -(define* (install-grub grub.cfg device mount-point) - "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on -MOUNT-POINT. Return #t on success." - (mkdir-p (string-append mount-point "/boot/grub")) - (symlink grub.cfg (string-append mount-point "/boot/grub/grub.cfg")) - (zero? (system* "grub-install" "--no-floppy" - "--boot-directory" (string-append mount-point "/boot") - device))) - (define* (populate-store reference-graphs target) "Populate the store under directory TARGET with the items specified in REFERENCE-GRAPHS, a list of reference-graph files." @@ -153,42 +145,6 @@ REFERENCE-GRAPHS, a list of reference-graph files." (string-append target thing))) (things-to-copy))) -(define (evaluate-populate-directive directive target) - "Evaluate DIRECTIVE, an sexp describing a file or directory to create under -directory TARGET." - (match directive - (('directory name) - (mkdir-p (string-append target name))) - (('directory name uid gid) - (let ((dir (string-append target name))) - (mkdir-p dir) - (chown dir uid gid))) - ((new '-> old) - (symlink old (string-append target new))))) - -(define (reset-timestamps directory) - "Reset the timestamps of all the files under DIRECTORY, so that they appear -as created and modified at the Epoch." - (display "clearing file timestamps...\n") - (for-each (lambda (file) - (let ((s (lstat file))) - ;; XXX: Guile uses libc's 'utime' function (not 'futime'), so - ;; the timestamp of symlinks cannot be changed, and there are - ;; symlinks here pointing to /gnu/store, which is the host, - ;; read-only store. - (unless (eq? (stat:type s) 'symlink) - (utime file 0 0 0 0)))) - (find-files directory ""))) - -(define (register-closure store closure) - "Register CLOSURE in STORE, where STORE is the directory name of the target -store and CLOSURE is the name of a file containing a reference graph as used -by 'guix-register'." - (let ((status (system* "guix-register" "--prefix" store - closure))) - (unless (zero? status) - (error "failed to register store items" closure)))) - (define MS_BIND 4096) ; again! (define* (initialize-hard-disk #:key -- cgit v1.3 From b4140694aca6a717ec130e3788b9d877d1b1e534 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 17 May 2014 17:39:30 +0200 Subject: system: Make /run/current-system at activation time. * gnu/system.scm (etc-directory): Change default value of #:profile. Change contents of SHELLS. Use /run/current-system/profile/{s,}bin in BASHRC. (operating-system-boot-script)[%modules]: Add (guix build linux-initrd). Add call to 'activate-current-system' in gexp. (operating-system-initrd-file, operating-system-grub.cfg): New procedures. (operating-system-derivation): Don't build grub.cfg here and remove it from the file union. * gnu/system/vm.scm (qemu-image): Remove #:populate. (operating-system-build-gid, operating-system-default-contents): Remove. (system-qemu-image): Remove call to 'operating-system-default-contents'. Use 'operating-system-grub.cfg' to get grub.cfg. Add GRUB.CFG to #:inputs. (system-qemu-image/shared-store): Likewise, but don't add GRUB.CFG to #:inputs. (system-qemu-image/shared-store-script): Pass --system kernel option. * guix/build/activation.scm (%booted-system, %current-system): New variables. (boot-time-system, activate-current-system): New procedures. * guix/build/install.scm (evaluate-populate-directive): Add case for ('directory name uid gid mode). (directives, populate-root-file-system): New procedures. * guix/build/vm.scm (initialize-hard-disk): Replace calls to 'evaluate-populate-directive' by a call to 'populate-root-file-system'. * gnu/services/dmd.scm (dmd-configuration-file): Use /run/current-system/profile/bin. * gnu/services/xorg.scm (slim-service): Likewise. --- gnu/services/dmd.scm | 2 +- gnu/services/xorg.scm | 2 +- gnu/system.scm | 56 ++++++++++++++++++++++++++++---------------- gnu/system/vm.scm | 59 ++++++----------------------------------------- guix/build/activation.scm | 33 +++++++++++++++++++++++++- guix/build/install.scm | 50 +++++++++++++++++++++++++++++++-------- guix/build/vm.scm | 3 +-- 7 files changed, 118 insertions(+), 87 deletions(-) (limited to 'gnu/system') diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index 0d1728589..982c196fe 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -64,7 +64,7 @@ services)) ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it. - (setenv "PATH" "/run/current-system/bin") + (setenv "PATH" "/run/current-system/profile/bin") (format #t "starting services...~%") (for-each start '#$(append-map service-provision services)))) diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index 1988cfa6a..7215297f6 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -139,7 +139,7 @@ When AUTO-LOGIN? is true, log in automatically as DEFAULT-USER." (mlet %store-monad ((startx (or startx (xorg-start-command))) (xinitrc (xinitrc))) (text-file* "slim.cfg" " -default_path /run/current-system/bin +default_path /run/current-system/profile/bin default_xserver " startx " xserver_arguments :0 vt7 xauth_path " xauth "/bin/xauth diff --git a/gnu/system.scm b/gnu/system.scm index 9ce94d023..ec3e2fcd6 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -55,6 +55,7 @@ operating-system-derivation operating-system-profile + operating-system-grub.cfg file-system @@ -263,7 +264,7 @@ explicitly appear in OS." (locale "C") (timezone "Europe/Paris") (skeletons '()) (pam-services '()) - (profile "/var/run/current-system/profile") + (profile "/run/current-system/profile") (sudoers "")) "Return a derivation that builds the static part of the /etc directory." (mlet* %store-monad @@ -273,8 +274,8 @@ explicitly appear in OS." (shells (text-file "shells" ; used by xterm and others "\ /bin/sh -/run/current-system/bin/sh -/run/current-system/bin/bash\n")) +/run/current-system/profile/bin/sh +/run/current-system/profile/bin/bash\n")) (issue (text-file "issue" " This is an alpha preview of the GNU system. Welcome. @@ -293,8 +294,8 @@ export LC_ALL=\"" locale "\" export TZ=\"" timezone "\" export TZDIR=\"" tzdata "/share/zoneinfo\" -export PATH=$HOME/.guix-profile/bin:" profile "/bin:" profile "/sbin -export PATH=/run/setuid-programs:$PATH +export PATH=/run/setuid-programs:/run/current-system/profile/sbin +export PATH=$HOME/.guix-profile/bin:/run/current-system/profile/bin:$PATH export CPATH=$HOME/.guix-profile/include:" profile "/include export LIBRARY_PATH=$HOME/.guix-profile/lib:" profile "/lib alias ls='ls -p --color' @@ -402,7 +403,8 @@ alias ll='ls -l' we're running in the final root." (define %modules '((guix build activation) - (guix build utils))) + (guix build utils) + (guix build linux-initrd))) (mlet* %store-monad ((services (operating-system-services os)) (etc (operating-system-etc-directory os)) @@ -446,6 +448,9 @@ we're running in the final root." ;; Activate setuid programs. (activate-setuid-programs (list #$@setuid-progs)) + ;; Set up /run/current-system. + (activate-current-system #:boot? #t) + ;; Close any remaining open file descriptors to be on the ;; safe side. This must be the very last thing we do, ;; because Guile has internal FDs such as 'sleep_pipe' @@ -466,8 +471,8 @@ we're running in the final root." (_ #f)) (operating-system-file-systems os))) -(define (operating-system-derivation os) - "Return a derivation that builds OS." +(define (operating-system-initrd-file os) + "Return a gexp denoting the initrd file of OS." (define boot-file-systems (filter (match-lambda (($ device "/") @@ -476,15 +481,16 @@ we're running in the final root." boot?)) (operating-system-file-systems os))) + (mlet %store-monad + ((initrd ((operating-system-initrd os) boot-file-systems))) + (return #~(string-append #$initrd "/initrd")))) + +(define (operating-system-grub.cfg os) + "Return the GRUB configuration file for OS." (mlet* %store-monad - ((profile (operating-system-profile os)) - (etc (operating-system-etc-directory os)) - (services (operating-system-services os)) - (boot (operating-system-boot-script os)) - (kernel -> (operating-system-kernel os)) - (initrd ((operating-system-initrd os) boot-file-systems)) - (initrd-file -> #~(string-append #$initrd "/initrd")) + ((system (operating-system-derivation os)) (root-fs -> (operating-system-root-file-system os)) + (kernel -> (operating-system-kernel os)) (entries -> (list (menu-entry (label (string-append "GNU system with " @@ -494,15 +500,25 @@ we're running in the final root." (linux-arguments (list (string-append "--root=" (file-system-device root-fs)) - #~(string-append "--load=" #$boot))) - (initrd initrd-file)))) - (grub.cfg (grub-configuration-file entries))) + #~(string-append "--system=" #$system) + #~(string-append "--load=" #$system + "/boot"))) + (initrd #~(string-append #$system "/initrd")))))) + (grub-configuration-file entries))) + +(define (operating-system-derivation os) + "Return a derivation that builds OS." + (mlet* %store-monad + ((profile (operating-system-profile os)) + (etc (operating-system-etc-directory os)) + (boot (operating-system-boot-script os)) + (kernel -> (operating-system-kernel os)) + (initrd (operating-system-initrd-file os))) (file-union "system" `(("boot" ,#~#$boot) ("kernel" ,#~#$kernel) - ("initrd" ,initrd-file) + ("initrd" ,initrd) ("profile" ,#~#$profile) - ("grub.cfg" ,#~#$grub.cfg) ("etc" ,#~#$etc))))) ;;; system.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 58e5416b3..4bf0e0608 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -192,7 +192,6 @@ made available under the /xchg CIFS share." (file-system-type "ext4") grub-configuration (register-closures? #t) - (populate #f) (inputs '()) copy-inputs?) "Return a bootable, stand-alone QEMU image, with a root partition of type @@ -203,12 +202,7 @@ file (GRUB-CONFIGURATION must be the name of a file in the VM.) INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy all of INPUTS into the image being built. When REGISTER-CLOSURES? is true, register INPUTS in the store database of the image so that Guix can be used in -the image. - -POPULATE is a list of directives stating directories or symlinks to be created -in the disk image partition. It is evaluated once the image has been -populated with INPUTS-TO-COPY. It can be used to provide additional files, -such as /etc files." +the image." (mlet %store-monad ((graph (sequence %store-monad (map input->name+output inputs)))) (expression->derivation-in-linux-vm @@ -241,8 +235,7 @@ such as /etc files." #:copy-closures? #$copy-inputs? #:register-closures? #$register-closures? #:disk-image-size #$disk-image-size - #:file-system-type #$file-system-type - #:directives '#$populate) + #:file-system-type #$file-system-type) (reboot)))) #:system system #:make-disk-image? #t @@ -254,39 +247,6 @@ such as /etc files." ;;; Stand-alone VM image. ;;; -(define (operating-system-build-gid os) - "Return as a monadic value the group id for build users of OS, or #f." - (mlet %store-monad ((services (operating-system-services os))) - (return (any (lambda (service) - (and (equal? '(guix-daemon) - (service-provision service)) - (match (service-user-groups service) - ((group) - (user-group-id group))))) - services)))) - -(define (operating-system-default-contents os) - "Return a list of directives suitable for 'system-qemu-image' describing the -basic contents of the root file system of OS." - (mlet* %store-monad ((os-drv (operating-system-derivation os)) - (build-gid (operating-system-build-gid os)) - (profile (operating-system-profile os))) - (return #~((directory #$(%store-prefix) 0 #$(or build-gid 0)) - (directory "/etc") - (directory "/var/log") ; for dmd - (directory "/var/run/nscd") - (directory "/var/guix/gcroots") - ("/var/guix/gcroots/system" -> #$os-drv) - (directory "/run") - ("/run/current-system" -> #$profile) - (directory "/bin") - ("/bin/sh" -> "/run/current-system/bin/bash") - (directory "/tmp") - (directory "/var/guix/profiles/per-user/root" 0 0) - - (directory "/root" 0 0) ; an exception - (directory "/home" 0 0))))) - (define* (system-qemu-image os #:key (file-system-type "ext4") @@ -312,14 +272,12 @@ of the GNU system as described by OS." file-systems-to-keep))))) (mlet* %store-monad ((os-drv (operating-system-derivation os)) - (os-dir -> (derivation->output-path os-drv)) - (grub.cfg -> (string-append os-dir "/grub.cfg")) - (populate (operating-system-default-contents os))) + (grub.cfg (operating-system-grub.cfg os))) (qemu-image #:grub-configuration grub.cfg - #:populate populate #:disk-image-size disk-image-size #:file-system-type file-system-type - #:inputs `(("system" ,os-drv)) + #:inputs `(("system" ,os-drv) + ("grub.cfg" ,grub.cfg)) #:copy-inputs? #t)))) (define (virtualized-operating-system os) @@ -356,11 +314,8 @@ environment with the store shared with the host." with the host." (mlet* %store-monad ((os-drv (operating-system-derivation os)) - (os-dir -> (derivation->output-path os-drv)) - (grub.cfg -> (string-append os-dir "/grub.cfg")) - (populate (operating-system-default-contents os))) + (grub.cfg (operating-system-grub.cfg os))) (qemu-image #:grub-configuration grub.cfg - #:populate populate #:disk-image-size disk-image-size #:inputs `(("system" ,os-drv)) @@ -390,7 +345,7 @@ exec " #$qemu "/bin/qemu-system-x86_64 -enable-kvm -no-reboot -net nic,model=vir -kernel " #$(operating-system-kernel os) "/bzImage \ -initrd " #$os-drv "/initrd \ -append \"" #$(if graphic? "" "console=ttyS0 ") - "--load=" #$os-drv "/boot --root=/dev/vda1\" \ + "--system=" #$os-drv " --load=" #$os-drv "/boot --root=/dev/vda1\" \ -serial stdio \ -drive file=" #$image ",if=virtio,cache=writeback,werror=report,readonly\n") diff --git a/guix/build/activation.scm b/guix/build/activation.scm index 267c592b5..49f98c021 100644 --- a/guix/build/activation.scm +++ b/guix/build/activation.scm @@ -18,13 +18,15 @@ (define-module (guix build activation) #:use-module (guix build utils) + #:use-module (guix build linux-initrd) #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (activate-users+groups activate-etc - activate-setuid-programs)) + activate-setuid-programs + activate-current-system)) ;;; Commentary: ;;; @@ -195,4 +197,33 @@ numeric gid or #f." (for-each make-setuid-program programs)) +(define %booted-system + ;; The system we booted in (a symlink.) + "/run/booted-system") + +(define %current-system + ;; The system that is current (a symlink.) This is not necessarily the same + ;; as %BOOTED-SYSTEM, for instance because we can re-build a new system + ;; configuration and activate it, without rebooting. + "/run/current-system") + +(define (boot-time-system) + "Return the '--system' argument passed on the kernel command line." + (find-long-option "--system" (linux-command-line))) + +(define* (activate-current-system #:optional (system (boot-time-system)) + #:key boot?) + "Atomically make SYSTEM the current system. When BOOT? is true, also make +it the booted system." + (format #t "making '~a' the current system...~%" system) + (when boot? + (when (file-exists? %booted-system) + (delete-file %booted-system)) + (symlink system %booted-system)) + + ;; Atomically make SYSTEM current. + (let ((new (string-append %current-system ".new"))) + (symlink system new) + (rename-file new %current-system))) + ;;; activation.scm ends here diff --git a/guix/build/install.scm b/guix/build/install.scm index 37153703e..a0be6e9d3 100644 --- a/guix/build/install.scm +++ b/guix/build/install.scm @@ -19,9 +19,10 @@ (define-module (guix build install) #:use-module (guix build utils) #:use-module (guix build install) + #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:export (install-grub - evaluate-populate-directive + populate-root-file-system reset-timestamps register-closure)) @@ -46,15 +47,44 @@ MOUNT-POINT. Return #t on success." (define (evaluate-populate-directive directive target) "Evaluate DIRECTIVE, an sexp describing a file or directory to create under directory TARGET." - (match directive - (('directory name) - (mkdir-p (string-append target name))) - (('directory name uid gid) - (let ((dir (string-append target name))) - (mkdir-p dir) - (chown dir uid gid))) - ((new '-> old) - (symlink old (string-append target new))))) + (let loop ((directive directive)) + (match directive + (('directory name) + (mkdir-p (string-append target name))) + (('directory name uid gid) + (let ((dir (string-append target name))) + (mkdir-p dir) + (chown dir uid gid))) + (('directory name uid gid mode) + (loop `(directory ,name ,uid ,gid)) + (chmod (string-append target name) mode)) + ((new '-> old) + (symlink old (string-append target new)))))) + +(define (directives store) + "Return a list of directives to populate the root file system that will host +STORE." + `((directory ,store 0 0) + (directory "/etc") + (directory "/var/log") ; for dmd + (directory "/var/run/nscd") + (directory "/var/guix/gcroots") + (directory "/run") + ("/var/guix/gcroots/booted-system" -> "/run/booted-system") + ("/var/guix/gcroots/current-system" -> "/run/current-system") + (directory "/bin") + ("/bin/sh" -> "/run/current-system/profile/bin/bash") + (directory "/tmp" 0 0 #o1777) ; sticky bit + (directory "/var/guix/profiles/per-user/root" 0 0) + + (directory "/root" 0 0) ; an exception + (directory "/home" 0 0))) + +(define (populate-root-file-system target) + "Make the essential non-store files and directories on TARGET. This +includes /etc, /var, /run, /bin/sh, etc." + (for-each (cut evaluate-populate-directive <> target) + (directives (%store-directory)))) (define (reset-timestamps directory) "Reset the timestamps of all the files under DIRECTORY, so that they appear diff --git a/guix/build/vm.scm b/guix/build/vm.scm index 12f952bd1..b9bb66cdb 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -206,8 +206,7 @@ further populate the partition." ;; Evaluate the POPULATE directives. (display "populating...\n") - (for-each (cut evaluate-populate-directive <> target-directory) - directives) + (populate-root-file-system target-directory) (unless (install-grub grub.cfg "/dev/sda" target-directory) (error "failed to install GRUB")) -- cgit v1.3 From d5b429abda948c21a61032a1da9d472410edaa90 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 18 May 2014 21:58:01 +0200 Subject: system: Add 'grub-configuration' record. * gnu/system/grub.scm (): New record type. (grub-configuration-file): Add 'config' parameter; remove #:default-entry and #:timeout. Honor CONFIG. * gnu/system.scm (): Remove 'bootloader-entries' field; remove default value for 'bootloader' field. (operating-system-grub.cfg): Pass the 'bootloader' field to 'grub-configuration-file'. * build-aux/hydra/demo-os.scm (bootloader): New field. --- build-aux/hydra/demo-os.scm | 3 +++ gnu/system.scm | 11 +++++------ gnu/system/grub.scm | 39 ++++++++++++++++++++++++++++++--------- 3 files changed, 38 insertions(+), 15 deletions(-) (limited to 'gnu/system') diff --git a/build-aux/hydra/demo-os.scm b/build-aux/hydra/demo-os.scm index 32c6fa3ab..fe9c77242 100644 --- a/build-aux/hydra/demo-os.scm +++ b/build-aux/hydra/demo-os.scm @@ -33,6 +33,7 @@ (gnu packages tor) (gnu packages package-management) + (gnu system grub) ; 'grub-configuration' (gnu system shadow) ; 'user-account' (gnu system linux) ; 'base-pam-services' (gnu services base) @@ -43,6 +44,8 @@ (host-name "gnu") (timezone "Europe/Paris") (locale "en_US.UTF-8") + (bootloader (grub-configuration + (device "/dev/sda"))) (file-systems ;; We provide a dummy file system for /, but that's OK because the VM build ;; code will automatically declare the / file system for us. diff --git a/gnu/system.scm b/gnu/system.scm index ec3e2fcd6..dd4487846 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -39,10 +39,11 @@ #:use-module (srfi srfi-26) #:export (operating-system operating-system? + + operating-system-bootloader operating-system-services operating-system-user-services operating-system-packages - operating-system-bootloader-entries operating-system-host-name operating-system-kernel operating-system-initrd @@ -83,10 +84,8 @@ operating-system? (kernel operating-system-kernel ; package (default linux-libre)) - (bootloader operating-system-bootloader ; package - (default grub)) - (bootloader-entries operating-system-bootloader-entries ; list - (default '())) + (bootloader operating-system-bootloader) ; + (initrd operating-system-initrd ; (list fs) -> M derivation (default qemu-initrd)) @@ -504,7 +503,7 @@ we're running in the final root." #~(string-append "--load=" #$system "/boot"))) (initrd #~(string-append #$system "/initrd")))))) - (grub-configuration-file entries))) + (grub-configuration-file (operating-system-bootloader os) entries))) (define (operating-system-derivation os) "Return a derivation that builds OS." diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm index 1893672a2..e789e4c59 100644 --- a/gnu/system/grub.scm +++ b/gnu/system/grub.scm @@ -25,8 +25,13 @@ #:use-module (guix gexp) #:use-module (ice-9 match) #:use-module (srfi srfi-1) - #:export (menu-entry + #:export (grub-configuration + grub-configuration? + grub-configuration-device + + menu-entry menu-entry? + grub-configuration-file)) ;;; Commentary: @@ -35,6 +40,19 @@ ;;; ;;; Code: +(define-record-type* + grub-configuration make-grub-configuration + grub-configuration? + (grub grub-configuration-grub ; package + (default (@ (gnu packages grub) grub))) + (device grub-configuration-device) ; string + (menu-entries grub-configuration-menu-entries ; list + (default '())) + (default-entry grub-configuration-default-entry ; integer + (default 1)) + (timeout grub-configuration-timeout ; integer + (default 5))) + (define-record-type* menu-entry make-menu-entry menu-entry? @@ -44,11 +62,13 @@ (default '())) ; list of string-valued gexps (initrd menu-entry-initrd)) ; file name of the initrd as a gexp -(define* (grub-configuration-file entries - #:key (default-entry 1) (timeout 5) - (system (%current-system))) - "Return the GRUB configuration file for ENTRIES, a list of - objects, defaulting to DEFAULT-ENTRY and with the given TIMEOUT." +(define* (grub-configuration-file config entries + #:key (system (%current-system))) + "Return the GRUB configuration file corresponding to CONFIG, a + object." + (define all-entries + (append entries (grub-configuration-menu-entries config))) + (define entry->gexp (match-lambda (($ label linux arguments initrd) @@ -67,12 +87,13 @@ set default=~a set timeout=~a search.file ~a/bzImage~%" - #$default-entry #$timeout + #$(grub-configuration-default-entry config) + #$(grub-configuration-timeout config) #$(any (match-lambda (($ _ linux) linux)) - entries)) - #$@(map entry->gexp entries)))) + all-entries)) + #$@(map entry->gexp all-entries)))) (gexp->derivation "grub.cfg" builder)) -- cgit v1.3 From e38e18ff010e53a788cec30f25ee3d59341b0708 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 19 May 2014 22:00:46 +0200 Subject: vm: Make the device name a parameter. * guix/build/vm.scm (initialize-partition-table): Honor 'device' parameter. (initialize-hard-disk): Add 'device' parameter and honor it. * gnu/system/vm.scm (qemu-image): Adjust accordingly. --- gnu/system/vm.scm | 3 ++- guix/build/vm.scm | 18 +++++++++++------- 2 files changed, 13 insertions(+), 8 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 4bf0e0608..ee9ac81ce 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -230,7 +230,8 @@ the image." (let ((graphs '#$(match inputs (((names . _) ...) names)))) - (initialize-hard-disk #:grub.cfg #$grub-configuration + (initialize-hard-disk "/dev/sda" + #:grub.cfg #$grub-configuration #:closures graphs #:copy-closures? #$copy-inputs? #:register-closures? #$register-closures? diff --git a/guix/build/vm.scm b/guix/build/vm.scm index e67b431b5..cf661a33f 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -121,7 +121,7 @@ The data at PORT is the format produced by #:references-graphs." "Create on DEVICE a partition table of type LABEL-TYPE, with a single partition of PARTITION-SIZE MiB. Return #t on success." (display "creating partition table...\n") - (zero? (system* "parted" "/dev/sda" "mklabel" label-type + (zero? (system* "parted" device "mklabel" label-type "mkpart" "primary" "ext2" "1MiB" (format #f "~aB" partition-size)))) @@ -147,7 +147,8 @@ REFERENCE-GRAPHS, a list of reference-graph files." (define MS_BIND 4096) ; again! -(define* (initialize-hard-disk #:key +(define* (initialize-hard-disk device + #:key grub.cfg disk-image-size (file-system-type "ext4") @@ -155,7 +156,7 @@ REFERENCE-GRAPHS, a list of reference-graph files." copy-closures? (register-closures? #t) (directives '())) - "Initialize /dev/sda, a disk of DISK-IMAGE-SIZE bytes, with a + "Initialize DEVICE, a disk of DISK-IMAGE-SIZE bytes, with a FILE-SYSTEM-TYPE partition, and with GRUB installed. If REGISTER-CLOSURES? is true, register all of CLOSURES is the partition's store. If COPY-CLOSURES? is true, copy all of CLOSURES to the partition. Lastly, apply DIRECTIVES to @@ -166,19 +167,22 @@ further populate the partition." (define target-store (string-append target-directory (%store-directory))) - (unless (initialize-partition-table "/dev/sda" + (define partition + (string-append device 1)) + + (unless (initialize-partition-table device #:partition-size (- disk-image-size (* 5 (expt 2 20)))) (error "failed to create partition table")) (format #t "creating ~a partition...\n" file-system-type) (unless (zero? (system* (string-append "mkfs." file-system-type) - "-F" "/dev/sda1")) + "-F" partition)) (error "failed to create partition")) (display "mounting partition...\n") (mkdir target-directory) - (mount "/dev/sda1" target-directory file-system-type) + (mount partition target-directory file-system-type) (when copy-closures? ;; Populate the store. @@ -208,7 +212,7 @@ further populate the partition." (display "populating...\n") (populate-root-file-system target-directory) - (unless (install-grub grub.cfg "/dev/sda" target-directory) + (unless (install-grub grub.cfg device target-directory) (error "failed to install GRUB")) ;; 'guix-register' resets timestamps and everything, so no need to do it -- 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') 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 c4a74364b9ddb5c34bce788d453f93aa307731dd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 22 May 2014 22:30:13 +0200 Subject: vm: Make the image format a parameter. * guix/build/vm.scm (load-in-linux-vm): Add #:disk-image-format parameter; add 'image-file' variable. Honor DISK-IMAGE-FORMAT. * gnu/system/vm.scm (expression->derivation-in-linux-vm): Add #:disk-image-format parameter, and honor it. (qemu-image): Likewise. --- gnu/system/vm.scm | 18 ++++++++++++------ guix/build/vm.scm | 10 +++++++--- 2 files changed, 19 insertions(+), 9 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 0d41791d8..39ce5bb6e 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -119,6 +119,7 @@ input tuple. The output file name is when building for SYSTEM." (make-disk-image? #f) (references-graphs #f) (memory-size 256) + (disk-image-format "qcow2") (disk-image-size (* 100 (expt 2 20)))) "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a @@ -127,8 +128,9 @@ store; it should put its output files in the `/xchg' directory, which is copied to the derivation's output when the VM terminates. The virtual machine runs with MEMORY-SIZE MiB of memory. -When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of -DISK-IMAGE-SIZE bytes and return it. +When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of type +DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), of DISK-IMAGE-SIZE bytes and +return it. MODULES is the set of modules imported in the execution environment of EXP. @@ -174,6 +176,7 @@ made available under the /xchg CIFS share." #:linux linux #:initrd initrd #:memory-size #$memory-size #:make-disk-image? #$make-disk-image? + #:disk-image-format #$disk-image-format #:disk-image-size #$disk-image-size #:references-graphs graphs)))) @@ -190,15 +193,17 @@ made available under the /xchg CIFS share." (system (%current-system)) (qemu qemu-headless) (disk-image-size (* 100 (expt 2 20))) + (disk-image-format "qcow2") (file-system-type "ext4") grub-configuration (register-closures? #t) (inputs '()) copy-inputs?) - "Return a bootable, stand-alone QEMU image, with a root partition of type -FILE-SYSTEM-TYPE. The returned image is a full disk image, with a GRUB -installation that uses GRUB-CONFIGURATION as its configuration -file (GRUB-CONFIGURATION must be the name of a file in the VM.) + "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g., +'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE. The +returned image is a full disk image, with a GRUB installation that uses +GRUB-CONFIGURATION as its configuration file (GRUB-CONFIGURATION must be the +name of a file in the VM.) INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy all of INPUTS into the image being built. When REGISTER-CLOSURES? is true, @@ -242,6 +247,7 @@ the image." #:system system #:make-disk-image? #t #:disk-image-size disk-image-size + #:disk-image-format disk-image-format #:references-graphs graph))) diff --git a/guix/build/vm.scm b/guix/build/vm.scm index 2a8843c63..4de536abb 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -50,6 +50,7 @@ (qemu (qemu-command)) (memory-size 512) linux initrd make-disk-image? (disk-image-size 100) + (disk-image-format "qcow2") (references-graphs '())) "Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy the result to OUTPUT. @@ -60,9 +61,12 @@ it via /dev/hda. REFERENCES-GRAPHS can specify a list of reference-graph files as produced by the #:references-graphs parameter of 'derivation'." + (define image-file + (string-append "image." disk-image-format)) (when make-disk-image? - (unless (zero? (system* "qemu-img" "create" "-f" "qcow2" "image.qcow2" + (unless (zero? (system* "qemu-img" "create" "-f" disk-image-format + image-file (number->string disk-image-size))) (error "qemu-img failed"))) @@ -92,12 +96,12 @@ the #:references-graphs parameter of 'derivation'." "-append" (string-append "console=ttyS0 --load=" builder) (if make-disk-image? - '("-hda" "image.qcow2") + `("-hda" ,image-file) '()))) (error "qemu failed" qemu)) (if make-disk-image? - (copy-file "image.qcow2" output) + (copy-file image-file output) (begin (mkdir output) (copy-recursively "xchg" output)))) -- cgit v1.3 From f19c6e5fe79c8bbd3c9ea25cd0380681bd99ce13 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 22 May 2014 22:32:53 +0200 Subject: vm: Use a para-virtualized disk when creating an image. * guix/build/vm.scm (load-in-linux-vm): When MAKE-DISK-IMAGE?, use '-drive ...,if=virtio' for better performance. * gnu/system/vm.scm (qemu-image): Use /dev/vda instead of /dev/sda. --- gnu/system/vm.scm | 2 +- guix/build/vm.scm | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 39ce5bb6e..7d0ffd971 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -236,7 +236,7 @@ the image." (let ((graphs '#$(match inputs (((names . _) ...) names)))) - (initialize-hard-disk "/dev/sda" + (initialize-hard-disk "/dev/vda" #:grub.cfg #$grub-configuration #:closures graphs #:copy-closures? #$copy-inputs? diff --git a/guix/build/vm.scm b/guix/build/vm.scm index 4de536abb..e559542f0 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -96,7 +96,8 @@ the #:references-graphs parameter of 'derivation'." "-append" (string-append "console=ttyS0 --load=" builder) (if make-disk-image? - `("-hda" ,image-file) + `("-drive" ,(string-append "file=" image-file + ",if=virtio")) '()))) (error "qemu failed" qemu)) -- cgit v1.3 From 1e77fedb46af3c131b46da7ced55f7078d0d0e5f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 22 May 2014 23:12:36 +0200 Subject: vm: Add 'system-disk-image'. * gnu/system/vm.scm (system-disk-image): New procedure. --- gnu/system/vm.scm | 40 ++++++++++++++++++++++++++++++++++++++-- 1 file changed, 38 insertions(+), 2 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 7d0ffd971..18635fd7e 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -54,7 +54,8 @@ qemu-image system-qemu-image system-qemu-image/shared-store - system-qemu-image/shared-store-script)) + system-qemu-image/shared-store-script + system-disk-image)) ;;; Commentary: @@ -252,9 +253,44 @@ the image." ;;; -;;; Stand-alone VM image. +;;; VM and disk images. ;;; +(define* (system-disk-image os + #:key + (file-system-type "ext4") + (disk-image-size (* 900 (expt 2 20))) + (volatile? #t)) + "Return the derivation of a disk image of DISK-IMAGE-SIZE bytes of the +system described by OS. Said image can be copied on a USB stick as is. When +VOLATILE? is true, the root file system is made volatile; this is useful +to USB sticks meant to be read-only." + (define file-systems-to-keep + (remove (lambda (fs) + (string=? (file-system-mount-point fs) "/")) + (operating-system-file-systems os))) + + (let ((os (operating-system (inherit os) + (initrd (cut qemu-initrd <> #:volatile-root? volatile?)) + + ;; Force our own root file system. + (file-systems (cons (file-system + (mount-point "/") + (device "/dev/sda1") + (type file-system-type)) + file-systems-to-keep))))) + + (mlet* %store-monad ((os-drv (operating-system-derivation os)) + (grub.cfg (operating-system-grub.cfg os))) + (qemu-image #:grub-configuration grub.cfg + #:disk-image-size disk-image-size + #:disk-image-format "raw" + #:file-system-type file-system-type + #:copy-inputs? #t + #:register-closures? #t + #:inputs `(("system" ,os-drv) + ("grub.cfg" ,grub.cfg)))))) + (define* (system-qemu-image os #:key (file-system-type "ext4") -- 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') 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