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'. --- guix/build/linux-initrd.scm | 38 +++++++++++++++++--------------------- 1 file changed, 17 insertions(+), 21 deletions(-) (limited to 'guix/build') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 61d4304b65..5d4446e720 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -143,7 +143,10 @@ (define (scope dir) (symlink "/proc/self/fd" (scope "dev/fd")) (symlink "/proc/self/fd/0" (scope "dev/stdin")) (symlink "/proc/self/fd/1" (scope "dev/stdout")) - (symlink "/proc/self/fd/2" (scope "dev/stderr"))) + (symlink "/proc/self/fd/2" (scope "dev/stderr")) + + ;; File systems in user space (FUSE). + (mknod (scope "dev/fuse") 'char-special #o666 (device-number 10 229))) (define %host-qemu-ipv4-address (inet-pton AF_INET "10.0.2.10")) @@ -212,7 +215,7 @@ (define* (boot-system #:key (linux-modules '()) qemu-guest-networking? guile-modules-in-chroot? - volatile-root? + volatile-root? unionfs (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 @@ -277,27 +280,20 @@ (define MS_RDONLY 1) (lambda () (if volatile-root? (begin - ;; XXX: For lack of a union file system... (mkdir-p "/real-root") (mount root "/real-root" "ext3" MS_RDONLY) - (mount "none" "/root" "tmpfs") - - ;; XXX: 'copy-recursively' cannot deal with device nodes, so - ;; explicitly avoid /dev. - (for-each (lambda (file) - (unless (string=? "dev" file) - (copy-recursively (string-append "/real-root/" - file) - (string-append "/root/" - file) - #:log (%make-void-port - "w")))) - (scandir "/real-root" - (lambda (file) - (not (member file '("." "..")))))) - - ;; TODO: Unmount /real-root. - ) + (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,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~%" -- cgit v1.2.3 From 395bea2a53ed7398e52a0a85370a554501af5678 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 16 Apr 2014 12:25:25 +0200 Subject: download: Improve progress report output. * guix/build/download.scm (url-fetch): Make current-output-port unbuffered. --- guix/build/download.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'guix/build') diff --git a/guix/build/download.scm b/guix/build/download.scm index 54115a9de2..5d881b93ee 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -307,7 +307,10 @@ (define (fetch uri file) uri) #f))) - (setvbuf (current-output-port) _IOLBF) + ;; Make this unbuffered so 'progress-proc' works as expected. _IOLBF means + ;; '\n', not '\r', so it's not appropriate here. + (setvbuf (current-output-port) _IONBF) + (setvbuf (current-error-port) _IOLBF) (let try ((uri uri)) -- cgit v1.2.3 From 06ed59825ecc0dc78d4d16d06c129e2f4879201a Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Sun, 27 Apr 2014 11:09:07 +0200 Subject: guix: cmake: Add input and package libraries to the rpath, and adapt package definitions accordingly. * guix/build/cmake-build-system.scm (configure): Add flags. * gnu/packages/maths.scm (lapack): Drop special code. * gnu/packages/ssh.scm (libssh): Drop special code. * gnu/packages/slim.scm (slim): Drop special code and enable shared library. Co-authored-by: Eric Bavier --- gnu/packages/maths.scm | 35 +++-------------------------------- gnu/packages/slim.scm | 12 +++--------- gnu/packages/ssh.scm | 35 +++-------------------------------- guix/build/cmake-build-system.scm | 5 +++++ 4 files changed, 14 insertions(+), 73 deletions(-) (limited to 'guix/build') diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm index 68c326752c..232b79b312 100644 --- a/gnu/packages/maths.scm +++ b/gnu/packages/maths.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Andreas Enge +;;; Copyright © 2013, 2014 Andreas Enge ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2014 John Darrington ;;; @@ -190,43 +190,14 @@ (define-public lapack (inputs `(("fortran" ,gfortran-4.8) ("python" ,python-2))) (arguments - `(#:modules ((guix build cmake-build-system) - (guix build utils) - (guix build rpath) - (srfi srfi-1)) - #:imported-modules ((guix build cmake-build-system) - (guix build gnu-build-system) - (guix build utils) - (guix build rpath)) - #:configure-flags '("-DBUILD_SHARED_LIBS:BOOL=YES") + `(#:configure-flags '("-DBUILD_SHARED_LIBS:BOOL=YES") #:phases (alist-cons-before 'check 'patch-python (lambda* (#:key inputs #:allow-other-keys) (let ((python (assoc-ref inputs "python"))) (substitute* "lapack_testing.py" (("/usr/bin/env python") python)))) - (alist-cons-after - 'strip 'add-libs-to-runpath - (lambda* (#:key inputs outputs #:allow-other-keys) - (let* ((out (assoc-ref outputs "out")) - (fortran (assoc-ref inputs "fortran")) - (libc (assoc-ref inputs "libc")) - (rpaths `(,(string-append fortran "/lib64") - ,(string-append fortran "/lib") - ,(string-append libc "/lib") - ,(string-append out "/lib")))) - ;; Set RUNPATH for all libraries - (with-directory-excursion out - (for-each - (lambda (lib) - (let ((lib-rpaths (file-rpath lib))) - (for-each - (lambda (dir) - (or (member dir lib-rpaths) - (augment-rpath lib dir))) - rpaths))) - (find-files "lib" ".*so$"))))) - %standard-phases)))) + %standard-phases))) (synopsis "Library for numerical linear algebra") (description "LAPACK is a Fortran 90 library for solving the most commonly occurring diff --git a/gnu/packages/slim.scm b/gnu/packages/slim.scm index f25b070f3c..cea3748985 100644 --- a/gnu/packages/slim.scm +++ b/gnu/packages/slim.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013 Guy Grant ;;; Copyright © 2014 Ludovic Courtès +;;; Copyright © 2014 Andreas Enge ;;; ;;; This file is part of GNU Guix. ;;; @@ -75,15 +76,8 @@ (define-public slim ;; "systemd". Strip that. ""))) %standard-phases) - #:configure-flags '("-DUSE_PAM=yes" "-DUSE_CONSOLEKIT=no" - - ;; Don't build libslim.so, because then the build - ;; system is unable to set the right RUNPATH on the - ;; 'slim' binary. - "-DBUILD_SHARED_LIBS=OFF" - - ;; Leave a valid RUNPATH upon install. - "-DCMAKE_SKIP_BUILD_RPATH=ON") + #:configure-flags '("-DUSE_PAM=yes" + "-DUSE_CONSOLEKIT=no") #:tests? #f)) (home-page "http://slim.berlios.de/") (synopsis "Desktop-independent graphcal login manager for X11") diff --git a/gnu/packages/ssh.scm b/gnu/packages/ssh.scm index 51e1990168..c8ed3be4a7 100644 --- a/gnu/packages/ssh.scm +++ b/gnu/packages/ssh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Andreas Enge +;;; Copyright © 2013, 2014 Andreas Enge ;;; Copyright © 2014 Mark H Weaver ;;; ;;; This file is part of GNU Guix. @@ -53,39 +53,10 @@ (define-public libssh "1jyaj9h1iglvn02hrvcchbx8ycjpj8b91h8mi459k7q5jp2xgd9b")))) (build-system cmake-build-system) (arguments - '(#:configure-flags '("-DWITH_GCRYPT=ON" - - ;; Leave a valid RUNPATH upon install. - "-DCMAKE_SKIP_BUILD_RPATH=ON") + '(#:configure-flags '("-DWITH_GCRYPT=ON") ;; TODO: Add 'CMockery' and '-DWITH_TESTING=ON' for the test suite. - #:tests? #f - - #:modules ((guix build cmake-build-system) - (guix build utils) - (guix build rpath)) - #:imported-modules ((guix build gnu-build-system) - (guix build cmake-build-system) - (guix build utils) - (guix build rpath)) - - #:phases (alist-cons-after - 'install 'augment-runpath - (lambda* (#:key outputs #:allow-other-keys) - ;; libssh_threads.so NEEDs libssh.so, so add $libdir to its - ;; RUNPATH. - (define (dereference file) - (let ((target (false-if-exception (readlink file)))) - (if target - (dereference target) - file))) - - (let* ((out (assoc-ref outputs "out")) - (lib (string-append out "/lib"))) - (with-directory-excursion lib - (augment-rpath (dereference "libssh_threads.so") - lib)))) - %standard-phases))) + #:tests? #f)) (inputs `(("zlib" ,zlib) ;; Link against an older gcrypt, because libssh tries to access ;; fields of 'gcry_thread_cbs' that are now private: diff --git a/guix/build/cmake-build-system.scm b/guix/build/cmake-build-system.scm index 75998568bc..144552e8de 100644 --- a/guix/build/cmake-build-system.scm +++ b/guix/build/cmake-build-system.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013 Ludovic Courtès ;;; Copyright © 2013 Cyril Roelandt +;;; Copyright © 2014 Andreas Enge ;;; ;;; This file is part of GNU Guix. ;;; @@ -48,6 +49,10 @@ (define* (configure #:key outputs (configure-flags '()) (out-of-source? #t) (let ((args `(,srcdir ,(string-append "-DCMAKE_INSTALL_PREFIX=" out) + ;; add input libraries to rpath + "-DCMAKE_INSTALL_RPATH_USE_LINK_PATH=TRUE" + ;; add (other) libraries of the project itself to rpath + ,(string-append "-DCMAKE_INSTALL_RPATH=" out "/lib") ,@configure-flags))) (setenv "CMAKE_LIBRARY_PATH" (getenv "LIBRARY_PATH")) (setenv "CMAKE_INCLUDE_PATH" (getenv "CPATH")) -- cgit v1.2.3 From 4dfe6c58ee204cf05ce9ef5abbc96ada44ef0784 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 30 Apr 2014 15:44:59 +0200 Subject: system: Add (guix build activation). * gnu/services/dmd.scm (dmd-configuration-file): Remove 'etc' parameter. Move /etc activation code to... * guix/build/activation.scm: ... here; new file. * gnu/system.scm (operating-system-boot-script): Augment script: add (guix build activation) to the load path; call 'activate-etc'. * Makefile.am (MODULES): Add guix/build/activation.scm. --- Makefile.am | 1 + gnu/services/dmd.scm | 27 ++------------------ gnu/system.scm | 21 +++++++++++++--- guix/build/activation.scm | 63 +++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 84 insertions(+), 28 deletions(-) create mode 100644 guix/build/activation.scm (limited to 'guix/build') diff --git a/Makefile.am b/Makefile.am index d01032f530..22bbdca13c 100644 --- a/Makefile.am +++ b/Makefile.am @@ -71,6 +71,7 @@ MODULES = \ guix/build/rpath.scm \ guix/build/svn.scm \ guix/build/vm.scm \ + guix/build/activation.scm \ guix/packages.scm \ guix/snix.scm \ guix/scripts/download.scm \ diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index c187c09857..161a971edd 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -30,9 +30,8 @@ (define-module (gnu services dmd) ;;; ;;; Code: -(define (dmd-configuration-file services etc) - "Return the dmd configuration file for SERVICES, that initializes /etc from -ETC (the derivation that builds the /etc directory) on startup." +(define (dmd-configuration-file services) + "Return the dmd configuration file for SERVICES." (define config #~(begin (use-modules (ice-9 ftw)) @@ -48,28 +47,6 @@ (define config #: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 '("." "..")))))) - - ;; 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") diff --git a/gnu/system.scm b/gnu/system.scm index 86904d9be2..4a85857582 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -256,10 +256,25 @@ (define (operating-system-boot-script os) (mlet* %store-monad ((services (sequence %store-monad (operating-system-services os))) (etc (operating-system-etc-directory os)) - (dmd-conf (dmd-configuration-file services etc))) + (modules (imported-modules '((guix build activation)))) + (compiled (compiled-modules '((guix build activation)))) + (dmd-conf (dmd-configuration-file services))) (gexp->file "boot" - #~(execl (string-append #$dmd "/bin/dmd") - "dmd" "--config" #$dmd-conf)))) + #~(begin + (eval-when (expand load eval) + ;; Make sure 'use-modules' below succeeds. + (set! %load-path (cons #$modules %load-path)) + (set! %load-compiled-path + (cons #$compiled %load-compiled-path))) + + (use-modules (guix build activation)) + + ;; Populate /etc. + (activate-etc #$etc) + + ;; Start dmd. + (execl (string-append #$dmd "/bin/dmd") + "dmd" "--config" #$dmd-conf))))) (define (operating-system-derivation os) "Return a derivation that builds OS." diff --git a/guix/build/activation.scm b/guix/build/activation.scm new file mode 100644 index 0000000000..c8491677d3 --- /dev/null +++ b/guix/build/activation.scm @@ -0,0 +1,63 @@ +;;; 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 activation) + #:use-module (ice-9 ftw) + #:export (activate-etc)) + +;;; Commentary: +;;; +;;; This module provides "activation" helpers. Activation is the process that +;;; consists in setting up system-wide files and directories so that an +;;; 'operating-system' configuration becomes active. +;;; +;;; Code: + +(define (activate-etc etc) + "Install ETC, a directory in the store, as the source of static files for +/etc." + + ;; /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 '("." "..")))) + + ;; The default is 'string-locale Date: Wed, 30 Apr 2014 22:11:01 +0200 Subject: linux-initrd: Allow setuid binaries from the unionfs to run. * guix/build/linux-initrd.scm (boot-system): Pass the 'suid' option to UNIONFS. --- guix/build/linux-initrd.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix/build') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 5d4446e720..4decc3b15c 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -290,7 +290,7 @@ (define MS_RDONLY 1) ;; Make /root a union of the tmpfs and the actual root. (unless (zero? (system* unionfs "-o" - "cow,allow_other,use_ino,dev" + "cow,allow_other,use_ino,suid,dev" "/rw-root=RW:/real-root=RO" "/root")) (error "unionfs failed"))) -- cgit v1.2.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 'guix/build') diff --git a/build-aux/hydra/demo-os.scm b/build-aux/hydra/demo-os.scm index c2ff012a1b..3987c4048d 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 4a85857582..ba105e2df1 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -106,7 +106,12 @@ (define-record-type* operating-system (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 @@ (define* (etc-directory #:key 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 @@ (define (operating-system-etc-directory os) (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 @@ (define (operating-system-etc-directory os) #: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 @@ (define (operating-system-boot-script os) ;; 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 efe27c55c3..4030d8860e 100644 --- a/gnu/system/linux.scm +++ b/gnu/system/linux.scm @@ -29,8 +29,8 @@ (define-module (gnu system linux) #: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 @@ (module "pam_motd.so") (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 c8491677d3..6930a8c585 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 @@ (define (activate-etc etc) (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 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 'guix/build') diff --git a/.dir-locals.el b/.dir-locals.el index a6135b171e..64a680c59f 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -17,6 +17,8 @@ (eval . (put 'with-directory-excursion 'scheme-indent-function 1)) (eval . (put 'package 'scheme-indent-function 0)) (eval . (put 'origin 'scheme-indent-function 0)) + (eval . (put 'operating-system 'scheme-indent-function 0)) + (eval . (put 'file-system 'scheme-indent-function 0)) (eval . (put 'manifest-entry 'scheme-indent-function 0)) (eval . (put 'manifest-pattern 'scheme-indent-function 0)) (eval . (put 'substitute-keyword-arguments 'scheme-indent-function 1)) diff --git a/doc/guix.texi b/doc/guix.texi index 3ae2b7e00b..99acad56e7 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3088,6 +3088,10 @@ Linux-Libre kernel, initial RAM disk, and boot loader looks like this: (host-name "komputilo") (timezone "Europe/Paris") (locale "fr_FR.UTF-8") + (file-systems (list (file-system + (device "/dev/disk/by-label/root") + (mount-point "/") + (type "ext3")))) (users (list (user-account (name "alice") (password "") diff --git a/gnu/system.scm b/gnu/system.scm index 6c94eb90c5..7624b10ae4 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -51,9 +51,20 @@ (define-module (gnu system) operating-system-timezone operating-system-locale operating-system-services + operating-system-file-systems operating-system-derivation - operating-system-profile)) + operating-system-profile + + + file-system + file-system? + file-system-device + file-system-mount-point + file-system-type + file-system-needed-for-boot? + file-system-flags + file-system-options)) ;;; Commentary: ;;; @@ -72,8 +83,8 @@ (define-record-type* operating-system (default grub)) (bootloader-entries operating-system-bootloader-entries ; list (default '())) - (initrd operating-system-initrd ; monadic derivation - (default (gnu-system-initrd))) + (initrd operating-system-initrd ; (list fs) -> M derivation + (default qemu-initrd)) (host-name operating-system-host-name) ; string @@ -112,6 +123,22 @@ (define-record-type* operating-system (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 @@ (define setuid-progs (execl (string-append #$dmd "/bin/dmd") "dmd" "--config" #$dmd-conf))))) +(define (operating-system-root-file-system os) + "Return the root file system of OS." + (find (match-lambda + (($ _ "/") #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 @@ (define (operating-system-derivation os) " (technology preview)")) (linux kernel) (linux-arguments - (list "--root=/dev/sda1" + (list (string-append "--root=" + (file-system-device root-fs)) #~(string-append "--load=" #$boot))) (initrd initrd-file)))) (grub.cfg (grub-configuration-file entries))) diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 6e04ad150f..8b4ab9c4eb 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -30,11 +30,12 @@ (define-module (gnu system linux-initrd) #:use-module (gnu packages guile) #:use-module ((gnu packages make-bootstrap) #:select (%guile-static-stripped)) + #:use-module (gnu system) ; for 'file-system' #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) #:export (expression->initrd - qemu-initrd - gnu-system-initrd)) + qemu-initrd)) ;;; Commentary: @@ -193,24 +194,29 @@ (define print0 (gexp->derivation name builder #:modules '((guix build utils))))) -(define* (qemu-initrd #:key +(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 @@ (define virtio-9p-modules ;; Modules for the 9p paravirtualized file system. '("9pnet.ko" "9p.ko" "9pnet_virtio.ko")) + (define (file-system-type-predicate type) + (lambda (fs) + (string=? (file-system-type fs) type))) + (define linux-modules ;; Modules added to the initrd and loaded from the initrd. `("virtio.ko" "virtio_ring.ko" "virtio_pci.ko" "virtio_balloon.ko" "virtio_blk.ko" "virtio_net.ko" - ,@(if (assoc-ref mounts 'cifs) + ,@(if (find (file-system-type-predicate "cifs") file-systems) cifs-modules '()) - ,@(if (assoc-ref mounts '9p) + ,@(if (find (file-system-type-predicate "9p") file-systems) virtio-9p-modules '()) ,@(if volatile-root? @@ -238,7 +248,7 @@ (define linux-modules (use-modules (guix build linux-initrd) (srfi srfi-26)) - (boot-system #:mounts '#$mounts + (boot-system #:mounts '#$(map file-system->spec file-systems) #:linux-modules '#$linux-modules #:qemu-guest-networking? #t #:guile-modules-in-chroot? '#$guile-modules-in-chroot? @@ -254,9 +264,4 @@ (define linux-modules #:linux linux-libre #:linux-modules linux-modules)) -(define (gnu-system-initrd) - "Initrd for the GNU system itself, with nothing QEMU-specific." - (qemu-initrd #:guile-modules-in-chroot? #f - #:mounts '())) - ;;; linux-initrd.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index db24c4e761..c080317415 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -82,6 +82,22 @@ (define* (input->name+output tuple #:key (system (%current-system))) ((input (and (? string?) (? store-path?) file)) (return `(,input . ,file)))))) +(define %linux-vm-file-systems + ;; File systems mounted for 'derivation-in-linux-vm'. The store and /xchg + ;; directory are shared with the host over 9p. + (list (file-system + (mount-point (%store-prefix)) + (device "store") + (type "9p") + (needed-for-boot? #t) + (options "trans=virtio")) + (file-system + (mount-point "/xchg") + (device "xchg") + (type "9p") + (needed-for-boot? #t) + (options "trans=virtio")))) + (define* (expression->derivation-in-linux-vm name exp #:key (system (%current-system)) @@ -130,9 +146,8 @@ (define* (expression->derivation-in-linux-vm name exp (coreutils -> (car (assoc-ref %final-inputs "coreutils"))) (initrd (if initrd ; use the default initrd? (return initrd) - (qemu-initrd #:guile-modules-in-chroot? #t - #:mounts `((9p "store" ,(%store-prefix)) - (9p "xchg" "/xchg")))))) + (qemu-initrd %linux-vm-file-systems + #:guile-modules-in-chroot? #t)))) (define builder ;; Code that launches the VM that evaluates EXP. @@ -292,6 +307,22 @@ (define* (system-qemu-image os #:initialize-store? #t #:inputs-to-copy `(("system" ,os-drv))))) +(define (virtualized-operating-system os) + "Return an operating system based on OS suitable for use in a virtualized +environment with the store shared with the host." + (operating-system (inherit os) + (initrd (cut qemu-initrd <> #:volatile-root? #t)) + (file-systems (list (file-system + (mount-point "/") + (device "/dev/vda1") + (type "ext3")) + (file-system + (mount-point (%store-prefix)) + (device "store") + (type "9p") + (needed-for-boot? #t) + (options "trans=virtio")))))) + (define* (system-qemu-image/shared-store os #:key (disk-image-size (* 15 (expt 2 20)))) @@ -314,14 +345,9 @@ (define* (system-qemu-image/shared-store-script (graphic? #t)) "Return a derivation that builds a script to run a virtual machine image of OS that shares its store with the host." - (define initrd - (qemu-initrd #:mounts `((9p "store" ,(%store-prefix))) - #:volatile-root? #t)) - (mlet* %store-monad - ((os -> (operating-system (inherit os) (initrd initrd))) + ((os -> (virtualized-operating-system os)) (os-drv (operating-system-derivation os)) - (initrd initrd) (image (system-qemu-image/shared-store os))) (define builder #~(call-with-output-file #$output @@ -332,7 +358,7 @@ (define builder -virtfs local,path=" #$(%store-prefix) ",security_model=none,mount_tag=store \ -net user \ -kernel " #$(operating-system-kernel os) "/bzImage \ - -initrd " #$initrd "/initrd \ + -initrd " #$os-drv "/initrd \ -append \"" #$(if graphic? "" "console=ttyS0 ") "--load=" #$os-drv "/boot --root=/dev/vda1\" \ -drive file=" #$image diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 4decc3b15c..1e0d6e27ec 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -30,8 +30,7 @@ (define-module (guix build linux-initrd) linux-command-line make-essential-device-nodes configure-qemu-networking - mount-qemu-smb-share - mount-qemu-9p + mount-file-system bind-mount load-linux-module* device-number @@ -170,33 +169,12 @@ (define* (configure-qemu-networking #:optional (interface "eth0")) (logand (network-interface-flags sock interface) IFF_UP))) -(define (mount-qemu-smb-share share mount-point) - "Mount QEMU's CIFS/SMB SHARE at MOUNT-POINT. - -Vanilla QEMU's `-smb' option just exports a /qemu share, whereas our -`qemu-with-multiple-smb-shares' package exports the /xchg and /store shares - (the latter allows the store to be shared between the host and guest.)" - - (format #t "mounting QEMU's SMB share `~a'...\n" share) - (let ((server "10.0.2.4")) - (mount (string-append "//" server share) mount-point "cifs" 0 - (string->pointer "guest,sec=none")))) - -(define (mount-qemu-9p source mount-point) - "Mount QEMU's 9p file system from SOURCE at MOUNT-POINT. - -This uses the 'virtio' transport, which requires the various virtio Linux -modules to be loaded." - - (format #t "mounting QEMU's 9p share '~a'...\n" source) - (let ((server "10.0.2.4")) - (mount source mount-point "9p" 0 - (string->pointer "trans=virtio")))) +;; Linux mount flags, from libc's . +(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 @@ (define (device-number major minor) the last argument of `mknod'." (+ (* major 256) minor)) +(define* (mount-root-file-system root type + #:key volatile-root? unionfs) + "Mount the root file system of type TYPE at device ROOT. If VOLATILE-ROOT? +is true, mount ROOT read-only and make it a union with a writable tmpfs using +UNIONFS." + (catch #t + (lambda () + (if volatile-root? + (begin + (mkdir-p "/real-root") + (mount root "/real-root" type MS_RDONLY) + (mkdir-p "/rw-root") + (mount "none" "/rw-root" "tmpfs") + + ;; We want read-write /dev nodes. + (make-essential-device-nodes #:root "/rw-root") + + ;; Make /root a union of the tmpfs and the actual root. + (unless (zero? (system* unionfs "-o" + "cow,allow_other,use_ino,suid,dev" + "/rw-root=RW:/real-root=RO" + "/root")) + (error "unionfs failed"))) + (mount root "/root" "ext3"))) + (lambda args + (format (current-error-port) "exception while mounting '~a': ~s~%" + root args) + (start-repl)))) + +(define* (mount-file-system spec #:key (root "/root")) + "Mount the file system described by SPEC under ROOT. SPEC must have the +form: + + (DEVICE MOUNT-POINT TYPE (FLAGS ...) OPTIONS) + +DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f; +FLAGS must be a list of symbols." + (define flags->bit-mask + (match-lambda + (('read-only rest ...) + (or MS_RDONLY (flags->bit-mask rest))) + (('bind-mount rest ...) + (or MS_BIND (flags->bit-mask rest))) + (() + 0))) + + (match spec + ((source mount-point type (flags ...) options) + (let ((mount-point (string-append root "/" mount-point))) + (mkdir-p mount-point) + (mount source mount-point type (flags->bit-mask flags) + (if options + (string->pointer options) + %null-pointer)))))) + (define* (boot-system #:key (linux-modules '()) qemu-guest-networking? guile-modules-in-chroot? volatile-root? unionfs + (root-fs-type "ext3") (mounts '())) "This procedure is meant to be called from an initrd. Boot a system by first loading LINUX-MODULES, then setting up QEMU guest networking if @@ -223,9 +257,7 @@ (define* (boot-system #:key and finally booting into the new root if any. The initrd supports kernel command-line options '--load', '--root', and '--repl'. -MOUNTS must be a list of elements of the form: - - (FILE-SYSTEM-TYPE SOURCE TARGET) +MOUNTS must be a list suitable for 'mount-file-system'. When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in the new root. @@ -241,8 +273,6 @@ (define (resolve file) (resolve (string-append "/root" target))) file))) - (define MS_RDONLY 1) - (display "Welcome, this is GNU's early boot Guile.\n") (display "Use '--repl' for an initrd REPL.\n\n") @@ -276,29 +306,9 @@ (define MS_RDONLY 1) (unless (file-exists? "/root") (mkdir "/root")) (if root - (catch #t - (lambda () - (if volatile-root? - (begin - (mkdir-p "/real-root") - (mount root "/real-root" "ext3" MS_RDONLY) - (mkdir-p "/rw-root") - (mount "none" "/rw-root" "tmpfs") - - ;; We want read-write /dev nodes. - (make-essential-device-nodes #:root "/rw-root") - - ;; Make /root a union of the tmpfs and the actual root. - (unless (zero? (system* unionfs "-o" - "cow,allow_other,use_ino,suid,dev" - "/rw-root=RW:/real-root=RO" - "/root")) - (error "unionfs failed"))) - (mount root "/root" "ext3"))) - (lambda args - (format (current-error-port) "exception while mounting '~a': ~s~%" - root args) - (start-repl))) + (mount-root-file-system root root-fs-type + #:volatile-root? volatile-root? + #:unionfs unionfs) (mount "none" "/root" "tmpfs")) (mount-essential-file-systems #:root "/root") @@ -308,16 +318,7 @@ (define MS_RDONLY 1) (make-essential-device-nodes #:root "/root")) ;; Mount the specified file systems. - (for-each (match-lambda - (('cifs source target) - (let ((target (string-append "/root/" target))) - (mkdir-p target) - (mount-qemu-smb-share source target))) - (('9p source target) - (let ((target (string-append "/root/" target))) - (mkdir-p target) - (mount-qemu-9p source target)))) - mounts) + (for-each mount-file-system mounts) (when guile-modules-in-chroot? ;; Copy the directories that contain .scm and .go files so that the -- cgit v1.2.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 'guix/build') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index c080317415..867e01ad5f 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -188,13 +188,15 @@ (define* (qemu-image #:key (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 @@ (define* (qemu-image #:key (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 @@ (define (virtualized-operating-system os) (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 1e0d6e27ec..fd6c0c4673 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -212,7 +212,7 @@ (define* (mount-root-file-system root type "/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 @@ (define* (boot-system #:key 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 @@ (define* (boot-system #:key 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 33c898d968..1d1abad1dd 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -183,7 +183,7 @@ (define (reset-timestamps directory) (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 @@ (define* (initialize-hard-disk #:key (- 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.2.3 From ad896f23a5fac38294e7515587c0c5bda02e9a59 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 May 2014 00:18:46 +0200 Subject: activation: Fix deletion of setuid programs. * guix/build/activation.scm (activate-setuid-programs): When %SETUID-DIRECTORY exists, pass the right file names to 'delete-file'. --- guix/build/activation.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix/build') diff --git a/guix/build/activation.scm b/guix/build/activation.scm index 6930a8c585..f9d9ba5cbd 100644 --- a/guix/build/activation.scm +++ b/guix/build/activation.scm @@ -19,6 +19,7 @@ (define-module (guix build activation) #:use-module (guix build utils) #:use-module (ice-9 ftw) + #:use-module (srfi srfi-26) #:export (activate-etc activate-setuid-programs)) @@ -85,7 +86,8 @@ (define (make-setuid-program prog) (format #t "setting up setuid programs in '~a'...~%" %setuid-directory) (if (file-exists? %setuid-directory) - (for-each delete-file + (for-each (compose delete-file + (cut string-append %setuid-directory "/" <>)) (scandir %setuid-directory (lambda (file) (not (member file '("." "..")))) -- cgit v1.2.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 'guix/build') diff --git a/gnu/system.scm b/gnu/system.scm index 7624b10ae4..65d1ca3418 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -349,8 +349,10 @@ (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 "/"))))) + (($ 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 8b4ab9c4eb..749dfa313f 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -198,8 +198,8 @@ (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)))) + (($ 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 @@ (define linux-modules '("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 786e564031..b20831f44d 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -90,13 +90,15 @@ (define %linux-vm-file-systems (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 @@ (define (virtualized-operating-system os) (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 fd6c0c4673..b2cbcae7d8 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -190,7 +190,7 @@ (define (device-number major minor) (+ (* 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 @@ (define* (mount-root-file-system root type "/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 @@ (define flags->bit-mask 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 @@ (define* (boot-system #:key (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 @@ (define* (boot-system #:key 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 @@ (define (resolve file) (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 @@ (define (resolve file) (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 @@ (define (resolve file) (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.2.3 From 1d4628329d37c5e5857c70f3720b941e4bbcfcd2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 May 2014 22:24:47 +0200 Subject: linux-initrd: Improve root file system switching. * guix/build/linux-initrd.scm (move-essential-file-systems, switch-root): New procedures. (MS_MOVE): New variable. (boot-system): Remove 'mount-essential-file-systems' call for ROOT. Use 'switch-root' instead of chdir + chroot. --- guix/build/linux-initrd.scm | 24 ++++++++++++++++++++---- 1 file changed, 20 insertions(+), 4 deletions(-) (limited to 'guix/build') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index b2cbcae7d8..b133550bca 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -62,6 +62,15 @@ (define (scope dir) (mkdir (scope "sys"))) (mount "none" (scope "sys") "sysfs")) +(define (move-essential-file-systems root) + "Move currently mounted essential file systems to ROOT." + (for-each (lambda (dir) + (let ((target (string-append root dir))) + (unless (file-exists? target) + (mkdir target)) + (mount dir target "" MS_MOVE))) + '("/proc" "/sys"))) + (define (linux-command-line) "Return the Linux kernel command line as a list of strings." (string-tokenize @@ -172,6 +181,7 @@ (define* (configure-qemu-networking #:optional (interface "eth0")) ;; Linux mount flags, from libc's . (define MS_RDONLY 1) (define MS_BIND 4096) +(define MS_MOVE 8192) (define (bind-mount source target) "Bind-mount SOURCE at TARGET." @@ -271,6 +281,15 @@ (define flags->bit-mask (string->pointer options) %null-pointer)))))) +(define (switch-root root) + "Switch to ROOT as the root file system, in a way similar to what +util-linux' switch_root(8) does." + (move-essential-file-systems root) + (chdir root) + ;; TODO: Delete files from the old root. + (mount root "/" "" MS_MOVE) + (chroot ".")) + (define* (boot-system #:key (linux-modules '()) qemu-guest-networking? @@ -351,8 +370,6 @@ (define root-fs-type #:volatile-root? volatile-root?) (mount "none" "/root" "tmpfs")) - (mount-essential-file-systems #:root "/root") - (unless (file-exists? "/root/dev") (mkdir "/root/dev") (make-essential-device-nodes #:root "/root")) @@ -377,8 +394,7 @@ (define root-fs-type (if to-load (begin (format #t "loading '~a'...\n" to-load) - (chdir "/root") - (chroot "/root") + (switch-root "/root") ;; Obviously this has to be done each time we boot. Do it from here ;; so that statfs(2) returns DEVPTS_SUPER_MAGIC like libc's getpt(3) -- cgit v1.2.3 From 26a728eb091daf89a01986eac2d51dc8f0b58b6a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 May 2014 18:09:25 +0200 Subject: linux-initrd: Delete files from the initrd ramfs when switching roots. * guix/build/linux-initrd.scm (switch-root): Delete file from the old root. Chdir to / after 'chroot' call. Re-open file descriptors 0, 1, and 2. (boot-system): Move 'loading' message after the 'switch-root' call. * gnu/system.scm (operating-system-boot-script): Add loop that closes file descriptor before calling 'execl'. --- gnu/system.scm | 9 +++++++++ guix/build/linux-initrd.scm | 48 ++++++++++++++++++++++++++++++++++++++++++--- 2 files changed, 54 insertions(+), 3 deletions(-) (limited to 'guix/build') diff --git a/gnu/system.scm b/gnu/system.scm index 65d1ca3418..8a5fe47b30 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -334,6 +334,15 @@ (define setuid-progs ;; Activate setuid programs. (activate-setuid-programs (list #$@setuid-progs)) + ;; 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' + ;; that need to be alive. + (let loop ((fd 3)) + (when (< fd 1024) + (false-if-exception (close-fdes fd)) + (loop (+ 1 fd)))) + ;; Start dmd. (execl (string-append #$dmd "/bin/dmd") "dmd" "--config" #$dmd-conf))))) diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index b133550bca..c09cdeafb4 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -286,9 +286,51 @@ (define (switch-root root) util-linux' switch_root(8) does." (move-essential-file-systems root) (chdir root) - ;; TODO: Delete files from the old root. + + ;; Since we're about to 'rm -rf /', try to make sure we're on an initrd. + ;; TODO: Use 'statfs' to check the fs type, like klibc does. + (when (or (not (file-exists? "/init")) (directory-exists? "/home")) + (format (current-error-port) + "The root file system is probably not an initrd; \ +bailing out.~%root contents: ~s~%" (scandir "/")) + (force-output (current-error-port)) + (exit 1)) + + ;; Delete files from the old root, without crossing mount points (assuming + ;; there are no mount points in sub-directories.) That means we're leaving + ;; the empty ROOT directory behind us, but that's OK. + (let ((root-device (stat:dev (stat "/")))) + (for-each (lambda (file) + (unless (member file '("." "..")) + (let* ((file (string-append "/" file)) + (device (stat:dev (lstat file)))) + (when (= device root-device) + (delete-file-recursively file))))) + (scandir "/"))) + + ;; Make ROOT the new root. (mount root "/" "" MS_MOVE) - (chroot ".")) + (chroot ".") + (chdir "/") + + (when (file-exists? "/dev/console") + ;; Close the standard file descriptors since they refer to the old + ;; /dev/console. + (for-each close-fdes '(0 1 2)) + + ;; Reopen them. + (let ((in (open-file "/dev/console" "rbl")) + (out (open-file "/dev/console" "wbl"))) + (dup2 (fileno in) 0) + (dup2 (fileno out) 1) + (dup2 (fileno out) 2) + + ;; Safely close IN and OUT. + (for-each (lambda (port) + (if (memv (fileno port) '(0 1 2)) + (set-port-revealed! port 1) + (close-port port))) + (list in out))))) (define* (boot-system #:key (linux-modules '()) @@ -393,8 +435,8 @@ (define root-fs-type (if to-load (begin - (format #t "loading '~a'...\n" to-load) (switch-root "/root") + (format #t "loading '~a'...\n" to-load) ;; Obviously this has to be done each time we boot. Do it from here ;; so that statfs(2) returns DEVPTS_SUPER_MAGIC like libc's getpt(3) -- cgit v1.2.3 From 538cc2e0165a32d3c5de9022f522f37880b60f5d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 7 May 2014 14:32:36 +0200 Subject: Remove now unneeded (guix build gnome) module. * guix/build/gnome.scm: Remove. * Makefile.am (MODULES): Update accordingly. --- Makefile.am | 1 - guix/build/gnome.scm | 31 ------------------------------- 2 files changed, 32 deletions(-) delete mode 100644 guix/build/gnome.scm (limited to 'guix/build') diff --git a/Makefile.am b/Makefile.am index 22bbdca13c..14e9e4a4b6 100644 --- a/Makefile.am +++ b/Makefile.am @@ -59,7 +59,6 @@ MODULES = \ guix/build/download.scm \ guix/build/cmake-build-system.scm \ guix/build/git.scm \ - guix/build/gnome.scm \ guix/build/gnu-build-system.scm \ guix/build/gnu-dist.scm \ guix/build/linux-initrd.scm \ diff --git a/guix/build/gnome.scm b/guix/build/gnome.scm deleted file mode 100644 index cac4de8f24..0000000000 --- a/guix/build/gnome.scm +++ /dev/null @@ -1,31 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Cyril Roelandt -;;; -;;; 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 gnome) - #:export (gir-directory)) - -;;; Commentary: -;;; -;;; Tools commonly used when building GNOME programs. -;;; -;;; Code: - -(define (gir-directory inputs pkg-name) - "Return the GIR directory name for PKG-NAME found from INPUTS." - (string-append (assoc-ref inputs pkg-name) - "/share/gir-1.0")) -- cgit v1.2.3 From b1995341ce803c396068a6e41f8cd64b09bbf2f6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 8 May 2014 00:22:26 +0200 Subject: linux-initrd: Update /etc/mtab. * guix/build/linux-initrd.scm (mount-root-file-system): Populate /root/etc/mtab. (mount-file-system): Update ROOT/etc/mtab. --- guix/build/linux-initrd.scm | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) (limited to 'guix/build') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index c09cdeafb4..6dd7c6e958 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -228,7 +228,9 @@ (define* (mount-root-file-system root type (lambda args (format (current-error-port) "exception while mounting '~a': ~s~%" root args) - (start-repl)))) + (start-repl))) + + (copy-file "/proc/mounts" "/root/etc/mtab")) (define (check-file-system device type) "Run a file system check of TYPE on DEVICE." @@ -279,7 +281,14 @@ (define flags->bit-mask (mount source mount-point type (flags->bit-mask flags) (if options (string->pointer options) - %null-pointer)))))) + %null-pointer)) + + ;; Update /etc/mtab. + (mkdir-p (string-append root "/etc")) + (let ((port (open-output-file (string-append root "/etc/mtab")))) + (format port "~a ~a ~a ~a 0 0~%" + source mount-point type options) + (close-port port)))))) (define (switch-root root) "Switch to ROOT as the root file system, in a way similar to what -- cgit v1.2.3 From 03178aec1dc63c630374b1aed2178140c185b9f5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 8 May 2014 19:44:44 +0200 Subject: git-download: Disable TLS certificate verification. * guix/build/git.scm (git-fetch): Add 'setenv' call. --- guix/build/git.scm | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'guix/build') diff --git a/guix/build/git.scm b/guix/build/git.scm index 4245594c38..68b132265b 100644 --- a/guix/build/git.scm +++ b/guix/build/git.scm @@ -31,6 +31,11 @@ (define* (git-fetch url commit directory #:key (git-command "git")) "Fetch COMMIT from URL into DIRECTORY. COMMIT must be a valid Git commit identifier. Return #t on success, #f otherwise." + + ;; Disable TLS certificate verification. The hash of the checkout is known + ;; in advance anyway. + (setenv "GIT_SSL_NO_VERIFY" "true") + (and (zero? (system* git-command "clone" url directory)) (with-directory-excursion directory (system* git-command "tag" "-l") -- cgit v1.2.3 From 474b832d5e596c5f0713afbcdea5a19c6770cfac Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 8 May 2014 23:21:45 +0200 Subject: linux-initrd: Don't leak /dev/console file descriptors. * guix/build/linux-initrd.scm (switch-root): Simplify /dev/console code. This fixes a bug where we would leak the IN and OUT file descriptors. --- guix/build/linux-initrd.scm | 25 +++++++++---------------- 1 file changed, 9 insertions(+), 16 deletions(-) (limited to 'guix/build') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 6dd7c6e958..16c741f931 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -324,22 +324,15 @@ (define (switch-root root) (when (file-exists? "/dev/console") ;; Close the standard file descriptors since they refer to the old - ;; /dev/console. - (for-each close-fdes '(0 1 2)) - - ;; Reopen them. - (let ((in (open-file "/dev/console" "rbl")) - (out (open-file "/dev/console" "wbl"))) - (dup2 (fileno in) 0) - (dup2 (fileno out) 1) - (dup2 (fileno out) 2) - - ;; Safely close IN and OUT. - (for-each (lambda (port) - (if (memv (fileno port) '(0 1 2)) - (set-port-revealed! port 1) - (close-port port))) - (list in out))))) + ;; /dev/console, and reopen them. + (let ((console (open-file "/dev/console" "r+b0"))) + (for-each close-fdes '(0 1 2)) + + (dup2 (fileno console) 0) + (dup2 (fileno console) 1) + (dup2 (fileno console) 2) + + (close-port console)))) (define* (boot-system #:key (linux-modules '()) -- cgit v1.2.3 From 02139eb9b2bdbe1b342a0550dd8725a764716c28 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 10 May 2014 21:47:05 +0200 Subject: linux-initrd: Append to /etc/mtab. * guix/build/linux-initrd.scm (mount-file-system): Open /etc/mtab in append mode. --- guix/build/linux-initrd.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix/build') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 16c741f931..83636dfd73 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -285,7 +285,7 @@ (define flags->bit-mask ;; Update /etc/mtab. (mkdir-p (string-append root "/etc")) - (let ((port (open-output-file (string-append root "/etc/mtab")))) + (let ((port (open-file (string-append root "/etc/mtab") "a"))) (format port "~a ~a ~a ~a 0 0~%" source mount-point type options) (close-port port)))))) -- cgit v1.2.3 From 29fa45f45d3192ad0f8d2c46523d7a7d6422c9e9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 10 May 2014 21:49:11 +0200 Subject: Add (guix build syscalls). * guix/build/syscalls.scm, tests/syscalls.scm: New files. * Makefile.am (MODULES): Add guix/build/syscalls.scm. (SCM_TESTS): Add tests/syscalls.scm. * guix/utils.scm (%libc-errno-pointer, errno): Remove; take from (guix build syscalls). --- Makefile.am | 4 +- guix/build/syscalls.scm | 156 ++++++++++++++++++++++++++++++++++++++++++++++++ guix/utils.scm | 33 +--------- tests/syscalls.scm | 47 +++++++++++++++ 4 files changed, 207 insertions(+), 33 deletions(-) create mode 100644 guix/build/syscalls.scm create mode 100644 tests/syscalls.scm (limited to 'guix/build') diff --git a/Makefile.am b/Makefile.am index 14e9e4a4b6..20bf650c9b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -71,6 +71,7 @@ MODULES = \ guix/build/svn.scm \ guix/build/vm.scm \ guix/build/activation.scm \ + guix/build/syscalls.scm \ guix/packages.scm \ guix/snix.scm \ guix/scripts/download.scm \ @@ -143,7 +144,8 @@ SCM_TESTS = \ tests/gexp.scm \ tests/nar.scm \ tests/union.scm \ - tests/profiles.scm + tests/profiles.scm \ + tests/syscalls.scm SH_TESTS = \ tests/guix-build.sh \ diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm new file mode 100644 index 0000000000..90cacc760b --- /dev/null +++ b/guix/build/syscalls.scm @@ -0,0 +1,156 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 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 syscalls) + #:use-module (system foreign) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 match) + #:export (errno + MS_RDONLY + MS_REMOUNT + MS_BIND + MS_MOVE + mount + umount)) + +;;; Commentary: +;;; +;;; This module provides bindings to libc's syscall wrappers. It uses the +;;; FFI, and thus requires a dynamically-linked Guile. (For statically-linked +;;; Guile, we instead apply 'guile-linux-syscalls.patch'.) +;;; +;;; Code: + +(define %libc-errno-pointer + ;; Glibc's 'errno' pointer. + (let ((errno-loc (dynamic-func "__errno_location" (dynamic-link)))) + (and errno-loc + (let ((proc (pointer->procedure '* errno-loc '()))) + (proc))))) + +(define errno + (if %libc-errno-pointer + (let ((bv (pointer->bytevector %libc-errno-pointer (sizeof int)))) + (lambda () + "Return the current errno." + ;; XXX: We assume that nothing changes 'errno' while we're doing all this. + ;; In particular, that means that no async must be running here. + + ;; Use one of the fixed-size native-ref procedures because they are + ;; optimized down to a single VM instruction, which reduces the risk + ;; that we fiddle with 'errno' (needed on Guile 2.0.5, libc 2.11.) + (let-syntax ((ref (lambda (s) + (syntax-case s () + ((_ bv) + (case (sizeof int) + ((4) + #'(bytevector-s32-native-ref bv 0)) + ((8) + #'(bytevector-s64-native-ref bv 0)) + (else + (error "unsupported 'int' size" + (sizeof int))))))))) + (ref bv)))) + (lambda () 0))) + +(define (augment-mtab source target type options) + "Augment /etc/mtab with information about the given mount point." + (let ((port (open-file "/etc/mtab" "a"))) + (format port "~a ~a ~a ~a 0 0~%" + source target type (or options "rw")) + (close-port port))) + +(define (read-mtab port) + "Read an mtab-formatted file from PORT, returning a list of tuples." + (let loop ((result '())) + (let ((line (read-line port))) + (if (eof-object? line) + (reverse result) + (loop (cons (string-tokenize line) result)))))) + +(define (remove-from-mtab target) + "Remove mount point TARGET from /etc/mtab." + (define entries + (remove (match-lambda + ((device mount-point type options freq passno) + (string=? target mount-point)) + (_ #f)) + (call-with-input-file "/etc/fstab" read-mtab))) + + (call-with-output-file "/etc/fstab" + (lambda (port) + (for-each (match-lambda + ((device mount-point type options freq passno) + (format port "~a ~a ~a ~a ~a ~a~%" + device mount-point type options freq passno))) + entries)))) + +;; Linux mount flags, from libc's . +(define MS_RDONLY 1) +(define MS_REMOUNT 32) +(define MS_BIND 4096) +(define MS_MOVE 8192) + +(define mount + (let* ((ptr (dynamic-func "mount" (dynamic-link))) + (proc (pointer->procedure int ptr `(* * * ,unsigned-long *)))) + (lambda* (source target type #:optional (flags 0) options + #:key (update-mtab? #t)) + "Mount device SOURCE on TARGET as a file system TYPE. Optionally, FLAGS +may be a bitwise-or of the MS_* constants, and OPTIONS may be a +string. When FLAGS contains MS_REMOUNT, SOURCE and TYPE are ignored. When +UPDATE-MTAB? is true, update /etc/mtab. Raise a 'system-error' exception on +error." + (let ((ret (proc (if source + (string->pointer source) + %null-pointer) + (string->pointer target) + (if type + (string->pointer type) + %null-pointer) + flags + (if options + (string->pointer options) + %null-pointer))) + (err (errno))) + (unless (zero? ret) + (throw 'system-error "mount" "mount ~S on ~S: ~A" + (list source target (strerror err)) + (list err))) + (when update-mtab? + (augment-mtab source target type options)))))) + +(define umount + (let* ((ptr (dynamic-func "umount2" (dynamic-link))) + (proc (pointer->procedure int ptr `(* ,int)))) + (lambda* (target #:optional (flags 0) + #:key (update-mtab? #t)) + "Unmount TARGET. Optionally FLAGS may be one of the MNT_* or UMOUNT_* +constants from ." + (let ((ret (proc (string->pointer target) flags)) + (err (errno))) + (unless (zero? ret) + (throw 'system-error "umount" "~S: ~A" + (list target (strerror err)) + (list err))) + (when update-mtab? + (remove-from-mtab target)))))) + +;;; syscalls.scm ends here diff --git a/guix/utils.scm b/guix/utils.scm index 53fc68d27b..700a191d71 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -28,6 +28,7 @@ (define-module (guix utils) #:use-module (rnrs bytevectors) #:use-module ((rnrs io ports) #:select (put-bytevector)) #:use-module ((guix build utils) #:select (dump-port)) + #:use-module ((guix build syscalls) #:select (errno)) #:use-module (ice-9 vlist) #:use-module (ice-9 format) #:autoload (ice-9 popen) (open-pipe*) @@ -366,38 +367,6 @@ (define F_xxLCK ((string-contains %host-type "linux") #(0 1 2)) ; *-linux-gnu (else #(1 2 3))))) ; *-gnu* -(define %libc-errno-pointer - ;; Glibc's 'errno' pointer. - (let ((errno-loc (dynamic-func "__errno_location" (dynamic-link)))) - (and errno-loc - (let ((proc (pointer->procedure '* errno-loc '()))) - (proc))))) - -(define errno - (if %libc-errno-pointer - (let ((bv (pointer->bytevector %libc-errno-pointer (sizeof int)))) - (lambda () - "Return the current errno." - ;; XXX: We assume that nothing changes 'errno' while we're doing all this. - ;; In particular, that means that no async must be running here. - - ;; Use one of the fixed-size native-ref procedures because they are - ;; optimized down to a single VM instruction, which reduces the risk - ;; that we fiddle with 'errno' (needed on Guile 2.0.5, libc 2.11.) - (let-syntax ((ref (lambda (s) - (syntax-case s () - ((_ bv) - (case (sizeof int) - ((4) - #'(bytevector-s32-native-ref bv 0)) - ((8) - #'(bytevector-s64-native-ref bv 0)) - (else - (error "unsupported 'int' size" - (sizeof int))))))))) - (ref bv)))) - (lambda () 0))) - (define fcntl-flock (let* ((ptr (dynamic-func "fcntl" (dynamic-link))) (proc (pointer->procedure int ptr `(,int ,int *)))) diff --git a/tests/syscalls.scm b/tests/syscalls.scm new file mode 100644 index 0000000000..5243ac9a34 --- /dev/null +++ b/tests/syscalls.scm @@ -0,0 +1,47 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 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 (test-syscalls) + #:use-module (guix build syscalls) + #:use-module (srfi srfi-64)) + +;; Test the (guix build syscalls) module, although there's not much that can +;; actually be tested without being root. + +(test-begin "syscalls") + +(test-equal "mount, ENOENT" + ENOENT + (catch 'system-error + (lambda () + (mount "/dev/null" "/does-not-exist" "ext2") + #f) + (compose system-error-errno list))) + +(test-equal "umount, ENOENT" + ENOENT + (catch 'system-error + (lambda () + (umount "/does-not-exist") + #f) + (compose system-error-errno list))) + +(test-end) + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) -- cgit v1.2.3 From 023f391c7860d21aee9e9b3e601d7a81bb5d128d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 10 May 2014 23:33:52 +0200 Subject: services: Add 'file-system-service'. * gnu/services/base.scm (file-system-service): New procedure. (user-processes-service): Add 'requirements' parameter. * gnu/services/dmd.scm (dmd-configuration-file): Use (guix build linux-initrd). * guix/build/linux-initrd.scm (guix): Export 'check-file-system'. * gnu/system.scm (file-union): New procedure. (essential-services): Use it. Add that to the returned list. --- gnu/services/base.scm | 30 ++++++++++++++++++++++++++++-- gnu/services/dmd.scm | 8 ++++++-- gnu/system.scm | 30 +++++++++++++++++++++++++----- guix/build/linux-initrd.scm | 1 + 4 files changed, 60 insertions(+), 9 deletions(-) (limited to 'guix/build') diff --git a/gnu/services/base.scm b/gnu/services/base.scm index e0f2888ee0..6431a3aaba 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -30,6 +30,7 @@ (define-module (gnu services base) #:use-module (srfi srfi-26) #:use-module (ice-9 format) #:export (root-file-system-service + file-system-service user-processes-service host-name-service mingetty-service @@ -87,19 +88,44 @@ (define (root-file-system-service) #f))))) (respawn? #f))))) -(define* (user-processes-service #:key (grace-delay 2)) +(define* (file-system-service device target type + #:key (check? #t) options) + "Return a service that mounts DEVICE on TARGET as a file system TYPE with +OPTIONS. When CHECK? is true, check the file system before mounting it." + (with-monad %store-monad + (return + (service + (provision (list (symbol-append 'file-system- (string->symbol target)))) + (requirement '(root-file-system)) + (documentation "Check, mount, and unmount the given file system.") + (start #~(lambda args + #$(if check? + #~(check-file-system #$device #$type) + #~#t) + (mount #$device #$target #$type 0 #$options) + #t)) + (stop #~(lambda args + ;; Normally there are no processes left at this point, so + ;; TARGET can be safely unmounted. + (umount #$target) + #f)))))) + +(define* (user-processes-service requirements #:key (grace-delay 2)) "Return the service that is responsible for terminating all the processes so that the root file system can be re-mounted read-only, just before rebooting/halting. Processes still running GRACE-DELAY seconds after SIGTERM has been sent are terminated with SIGKILL. +The returned service will depend on 'root-file-system' and on all the services +listed in REQUIREMENTS. + All the services that spawn processes must depend on this one so that they are stopped before 'kill' is called." (with-monad %store-monad (return (service (documentation "When stopped, terminate all user processes.") (provision '(user-processes)) - (requirement '(root-file-system)) + (requirement (cons 'root-file-system requirements)) (start #~(const #t)) (stop #~(lambda _ ;; When this happens, all the processes have been diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index 8d4c483cc4..0d17285890 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -34,7 +34,9 @@ (define (dmd-configuration-file services) "Return the dmd configuration file for SERVICES." (define modules ;; Extra modules visible to dmd.conf. - '((guix build syscalls))) + '((guix build syscalls) + (guix build linux-initrd) + (guix build utils))) (mlet %store-monad ((modules (imported-modules modules)) (compiled (compiled-modules modules))) @@ -46,7 +48,9 @@ (define config (cons #$compiled %load-compiled-path))) (use-modules (ice-9 ftw) - (guix build syscalls)) + (guix build syscalls) + ((guix build linux-initrd) + #:select (check-file-system))) (register-services #$@(map (lambda (service) diff --git a/gnu/system.scm b/gnu/system.scm index 491e0ed7ae..d76c3670f0 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -184,15 +184,35 @@ (define builder (gexp->derivation name builder)) +(define (other-file-system-services os) + "Return file system services for the file systems of OS that are not marked +as 'needed-for-boot'." + (define file-systems + (remove (lambda (fs) + (or (file-system-needed-for-boot? fs) + (string=? "/" (file-system-mount-point fs)))) + (operating-system-file-systems os))) + + (sequence %store-monad + (map (match-lambda + (($ device target type flags opts #f check?) + (file-system-service device target type + #:check? check? + #:options opts))) + file-systems))) + (define (essential-services os) "Return the list of essential services for OS. These are special services that implement part of what's declared in OS are responsible for low-level bookkeeping." - (mlet %store-monad ((procs (user-processes-service)) - (root-fs (root-file-system-service)) - (host-name (host-name-service - (operating-system-host-name os)))) - (return (list host-name procs root-fs)))) + (mlet* %store-monad ((root-fs (root-file-system-service)) + (other-fs (other-file-system-services os)) + (procs (user-processes-service + (map (compose first service-provision) + other-fs))) + (host-name (host-name-service + (operating-system-host-name os)))) + (return (cons* host-name procs root-fs other-fs)))) (define (operating-system-services os) "Return all the services of OS, including \"internal\" services that do not diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 83636dfd73..0c3b2f0d9f 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -30,6 +30,7 @@ (define-module (guix build linux-initrd) linux-command-line make-essential-device-nodes configure-qemu-networking + check-file-system mount-file-system bind-mount load-linux-module* -- cgit v1.2.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 'guix/build') diff --git a/build-aux/hydra/demo-os.scm b/build-aux/hydra/demo-os.scm index 03449abda2..4116c063f4 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 6431a3aaba..1f5ff3e4cb 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -237,8 +237,8 @@ (define contents " (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 @@ (define* (guix-build-accounts count #:key (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 @@ (define* (guix-build-accounts count #:key 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 @@ (define* (guix-service #:key (guix guix) (builder-group "guixbuild") (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 d76c3670f0..bd69532a89 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -224,17 +224,12 @@ (define (operating-system-services 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 @@ (define* (etc-directory #:key ("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 @@ (define (operating-system-profile os) (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 @@ (define (operating-system-etc-directory os) (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 @@ (define %sudoers-specification "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 @@ (define %modules '((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 @@ (define setuid-progs ;; 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 3a43eb45e3..5440f5852f 100644 --- a/gnu/system/linux.scm +++ b/gnu/system/linux.scm @@ -154,11 +154,13 @@ (module "pam_motd.so") (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 52242ee4e0..8745ddb876 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -30,9 +30,10 @@ (define-module (gnu system shadow) #: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 @@ (define-module (gnu system shadow) 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 @@ (define-record-type* 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 @@ (define-record-type* 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 2520853205..ede7ea7726 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -267,16 +267,6 @@ (define (operating-system-build-gid os) (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 @@ (define (user-directories user) (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 f9d9ba5cbd..895f2bca5b 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 @@ (define-module (guix build activation) ;;; ;;; 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.2.3 From 17a4d344899dca6a429fc79bc3b54edbe5079956 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 14 May 2014 16:35:35 +0200 Subject: syscalls: Add 'processes' to list all the live processes. * guix/build/syscalls.scm (kernel?, processes): New procedures. --- guix/build/syscalls.scm | 29 ++++++++++++++++++++++++++++- 1 file changed, 28 insertions(+), 1 deletion(-) (limited to 'guix/build') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 90cacc760b..7a1bad7331 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -22,13 +22,15 @@ (define-module (guix build syscalls) #:use-module (srfi srfi-1) #:use-module (ice-9 rdelim) #:use-module (ice-9 match) + #:use-module (ice-9 ftw) #:export (errno MS_RDONLY MS_REMOUNT MS_BIND MS_MOVE mount - umount)) + umount + processes)) ;;; Commentary: ;;; @@ -153,4 +155,29 @@ (define umount (when update-mtab? (remove-from-mtab target)))))) +(define (kernel? pid) + "Return #t if PID designates a \"kernel thread\" rather than a normal +user-land process." + (let ((stat (call-with-input-file (format #f "/proc/~a/stat" pid) + (compose string-tokenize read-string)))) + ;; See proc.txt in Linux's documentation for the list of fields. + (match stat + ((pid tcomm state ppid pgrp sid tty_nr tty_pgrp flags min_flt + cmin_flt maj_flt cmaj_flt utime stime cutime cstime + priority nice num_thread it_real_value start_time + vsize rss rsslim + (= string->number start_code) (= string->number end_code) _ ...) + ;; Got this obscure trick from sysvinit's 'killall5' program. + (and (zero? start_code) (zero? end_code)))))) + +(define (processes) + "Return the list of live processes." + (sort (filter-map (lambda (file) + (let ((pid (string->number file))) + (and pid + (not (kernel? pid)) + pid))) + (scandir "/proc")) + <)) + ;;; syscalls.scm ends here -- cgit v1.2.3 From 7d57cfd3b6625d7ab7f796b90b9606c28ec3aeef Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 14 May 2014 16:38:21 +0200 Subject: system: When unionfs-fuse is used for /, don't kill it when halting. * guix/build/linux-initrd.scm (pidof): New procedure. (mount-root-file-system)[mark-as-not-killable]: New procedure. Use it for unionfs when VOLATILE-ROOT?. * gnu/services/base.scm (%do-not-kill-file): New variable. (user-processes-service)[stop]: Honor it. --- gnu/services/base.scm | 42 +++++++++++++++++++++++++++++++++++++++--- guix/build/linux-initrd.scm | 26 +++++++++++++++++++++++++- 2 files changed, 64 insertions(+), 4 deletions(-) (limited to 'guix/build') diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 1f5ff3e4cb..aec6050588 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -110,6 +110,11 @@ (define* (file-system-service device target type (umount #$target) #f)))))) +(define %do-not-kill-file + ;; Name of the file listing PIDs of processes that must survive when halting + ;; the system. Typical example is user-space file systems. + "/etc/dmd/do-not-kill") + (define* (user-processes-service requirements #:key (grace-delay 2)) "Return the service that is responsible for terminating all the processes so that the root file system can be re-mounted read-only, just before @@ -128,6 +133,25 @@ (define* (user-processes-service requirements #:key (grace-delay 2)) (requirement (cons 'root-file-system requirements)) (start #~(const #t)) (stop #~(lambda _ + (define (kill-except omit signal) + ;; Kill all the processes with SIGNAL except those + ;; listed in OMIT and the current process. + (let ((omit (cons (getpid) omit))) + (for-each (lambda (pid) + (unless (memv pid omit) + (false-if-exception + (kill pid signal)))) + (processes)))) + + (define omitted-pids + ;; List of PIDs that must not be killed. + (if (file-exists? #$%do-not-kill-file) + (map string->number + (call-with-input-file #$%do-not-kill-file + (compose string-tokenize + (@ (ice-9 rdelim) read-string)))) + '())) + ;; When this happens, all the processes have been ;; killed, including 'deco', so DMD-OUTPUT-PORT and ;; thus CURRENT-OUTPUT-PORT are dangling. @@ -136,9 +160,21 @@ (define* (user-processes-service requirements #:key (grace-delay 2)) (display "sending all processes the TERM signal\n" port))) - (kill -1 SIGTERM) - (sleep #$grace-delay) - (kill -1 SIGKILL) + (if (null? omitted-pids) + (begin + ;; Easy: terminate all of them. + (kill -1 SIGTERM) + (sleep #$grace-delay) + (kill -1 SIGKILL)) + (begin + ;; Kill them all except OMITTED-PIDS. XXX: We + ;; would like to (kill -1 SIGSTOP) to get a fixed + ;; list of processes, like 'killall5' does, but + ;; that seems unreliable. + (kill-except omitted-pids SIGTERM) + (sleep #$grace-delay) + (kill-except omitted-pids SIGKILL) + (delete-file #$%do-not-kill-file))) (display "all processes have been terminated\n") #f)) diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 0c3b2f0d9f..b488668ee2 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -200,11 +200,30 @@ (define (device-number major minor) the last argument of `mknod'." (+ (* major 256) minor)) +(define (pidof program) + "Return the PID of the first presumed instance of PROGRAM." + (let ((program (basename program))) + (find (lambda (pid) + (let ((exe (format #f "/proc/~a/exe" pid))) + (and=> (false-if-exception (readlink exe)) + (compose (cut string=? program <>) basename)))) + (filter-map string->number (scandir "/proc"))))) + (define* (mount-root-file-system root type #: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." + (define (mark-as-not-killable pid) + ;; Tell the 'user-processes' dmd service that PID must be kept alive when + ;; shutting down. + (mkdir-p "/root/etc/dmd") + (let ((port (open-file "/root/etc/dmd/do-not-kill" "a"))) + (chmod port #o600) + (write pid port) + (newline port) + (close-port port))) + (catch #t (lambda () (if volatile-root? @@ -222,7 +241,12 @@ (define* (mount-root-file-system root type "cow,allow_other,use_ino,suid,dev" "/rw-root=RW:/real-root=RO" "/root")) - (error "unionfs failed"))) + (error "unionfs failed")) + + ;; Make sure unionfs remains alive till the end. Because + ;; 'fuse_daemonize' doesn't tell the PID of the forked daemon, we + ;; have to resort to 'pidof' here. + (mark-as-not-killable (pidof unionfs))) (begin (check-file-system root type) (mount root "/root" type)))) -- cgit v1.2.3 From 7f17ff78419b6088cbc8cec6e5f567a317fba809 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 14 May 2014 16:38:47 +0200 Subject: linux-initrd: Make /dev/ttyS0, for debugging. * guix/build/linux-initrd.scm (make-essential-device-nodes): Make /dev/ttyS0. --- guix/build/linux-initrd.scm | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'guix/build') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index b488668ee2..a89ff86bbb 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -124,6 +124,10 @@ (define (scope dir) (device-number 4 n)) (loop (+ 1 n))))) + ;; Serial line. + (mknod (scope "dev/ttyS0") 'char-special #o660 + (device-number 4 64)) + ;; Pseudo ttys. (mknod (scope "dev/ptmx") 'char-special #o666 (device-number 5 2)) -- cgit v1.2.3 From f3b692acdd6da6c6a660f3d1b8de79e7f6ca25c7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 14 May 2014 19:05:21 +0200 Subject: activation: Silence warning from 'useradd'. * guix/build/activation.scm (add-user): Don't pass '--create-home' when HOME already exists. --- guix/build/activation.scm | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'guix/build') diff --git a/guix/build/activation.scm b/guix/build/activation.scm index 895f2bca5b..267c592b52 100644 --- a/guix/build/activation.scm +++ b/guix/build/activation.scm @@ -73,7 +73,11 @@ (define* (add-user name group `("-G" ,(string-join supplementary-groups ",")) '()) ,@(if comment `("-c" ,comment) '()) - ,@(if home `("-d" ,home "--create-home") '()) + ,@(if home + (if (file-exists? home) + `("-d" ,home) ; avoid warning from 'useradd' + `("-d" ,home "--create-home")) + '()) ,@(if shell `("-s" ,shell) '()) ,@(if password `("-p" ,password) '()) ,name))) -- cgit v1.2.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 'guix/build') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index f42feb394c..7008c5dab2 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -192,25 +192,26 @@ (define* (qemu-image #:key (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 @@ (define* (qemu-image #:key '#$(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 @@ (define file-systems-to-keep #: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 @@ (define* (system-qemu-image/shared-store (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 1d1abad1dd..2c13a8904b 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -180,13 +180,36 @@ (define (reset-timestamps directory) (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 @@ (define* (initialize-hard-disk #:key (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.2.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 'guix/build') diff --git a/Makefile.am b/Makefile.am index 20bf650c9b..a08215ef1e 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 7008c5dab2..58e5416b3e 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -109,6 +109,7 @@ (define* (expression->derivation-in-linux-vm name exp (env-vars '()) (modules '((guix build vm) + (guix build install) (guix build linux-initrd) (guix build utils))) (guile-for-build @@ -179,9 +180,7 @@ (define builder ;; 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 0000000000..37153703e5 --- /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 2c13a8904b..12f952bd11 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 @@ (define* (initialize-partition-table device "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 @@ (define (graph-from-file file) (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.2.3 From 87a52da7d0da82bd8df9c86dcac7029c375b50c0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 16 May 2014 23:31:48 +0200 Subject: linux-initrd: Factorize kernel command-line option parsing. * guix/build/linux-initrd.scm (find-long-option): New procedure. (boot-system): Use it instead of the local 'option'. --- guix/build/linux-initrd.scm | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) (limited to 'guix/build') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index a89ff86bbb..9093e72695 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -28,6 +28,7 @@ (define-module (guix build linux-initrd) #:use-module (guix build utils) #:export (mount-essential-file-systems linux-command-line + find-long-option make-essential-device-nodes configure-qemu-networking check-file-system @@ -78,6 +79,15 @@ (define (linux-command-line) (call-with-input-file "/proc/cmdline" get-string-all))) +(define (find-long-option option arguments) + "Find OPTION among ARGUMENTS, where OPTION is something like \"--load\". +Return the value associated with OPTION, or #f on failure." + (let ((opt (string-append option "="))) + (and=> (find (cut string-prefix? opt <>) + arguments) + (lambda (arg) + (substring arg (+ 1 (string-index arg #\=))))))) + (define* (make-essential-device-nodes #:key (root "/")) "Make essential device nodes under ROOT/dev." ;; The hand-made udev! @@ -411,14 +421,8 @@ (define root-fs-type (mount-essential-file-systems) (let* ((args (linux-command-line)) - (option (lambda (opt) - (let ((opt (string-append opt "="))) - (and=> (find (cut string-prefix? opt <>) - args) - (lambda (arg) - (substring arg (+ 1 (string-index arg #\=)))))))) - (to-load (option "--load")) - (root (option "--root"))) + (to-load (find-long-option "--load" args)) + (root (find-long-option "--root" args))) (when (member "--repl" args) (start-repl)) -- cgit v1.2.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 'guix/build') diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index 0d17285890..982c196fe4 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -64,7 +64,7 @@ (define config 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 1988cfa6a0..7215297f69 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -139,7 +139,7 @@ (define (slim.cfg) (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 9ce94d0230..ec3e2fcd6c 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -55,6 +55,7 @@ (define-module (gnu system) operating-system-derivation operating-system-profile + operating-system-grub.cfg file-system @@ -263,7 +264,7 @@ (define* (etc-directory #:key (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 @@ (define* (etc-directory #:key (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 @@ (define* (etc-directory #:key 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 @@ (define (operating-system-boot-script os) 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 @@ (define group-specs ;; 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 @@ (define (operating-system-root-file-system os) (_ #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 @@ (define boot-file-systems 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 @@ (define boot-file-systems (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 58e5416b3e..4bf0e06081 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -192,7 +192,6 @@ (define* (qemu-image #:key (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 @@ (define* (qemu-image #:key 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 @@ (define* (qemu-image #:key #: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 @@ (define* (qemu-image #:key ;;; 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 @@ (define file-systems-to-keep 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 @@ (define* (system-qemu-image/shared-store 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 @@ (define builder -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 267c592b52..49f98c021d 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 @@ (define (make-setuid-program prog) (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 37153703e5..a0be6e9d39 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 @@ (define* (install-grub grub.cfg device mount-point) (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 12f952bd11..b9bb66cdb7 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -206,8 +206,7 @@ (define target-store ;; 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.2.3 From 15d299874c635d14a84710005d0ed4b05968ff6f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 18 May 2014 19:11:53 +0200 Subject: vm: Avoid resetting timestamps twice. * guix/build/vm.scm (initialize-hard-disk): Don't call 'reset-timestamps' when REGISTER-CLOSURES? is true. * guix/build/install.scm (register-closure): Mention timestamps in docstring. --- guix/build/install.scm | 2 +- guix/build/vm.scm | 5 ++++- 2 files changed, 5 insertions(+), 2 deletions(-) (limited to 'guix/build') diff --git a/guix/build/install.scm b/guix/build/install.scm index a0be6e9d39..564735a7f6 100644 --- a/guix/build/install.scm +++ b/guix/build/install.scm @@ -103,7 +103,7 @@ (define (reset-timestamps 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'." +by 'guix-register'. As a side effect, this resets timestamps on store files." (let ((status (system* "guix-register" "--prefix" store closure))) (unless (zero? status) diff --git a/guix/build/vm.scm b/guix/build/vm.scm index b9bb66cdb7..e67b431b5a 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -211,7 +211,10 @@ (define target-store (unless (install-grub grub.cfg "/dev/sda" target-directory) (error "failed to install GRUB")) - (reset-timestamps target-directory) + ;; 'guix-register' resets timestamps and everything, so no need to do it + ;; once more in that case. + (unless register-closures? + (reset-timestamps target-directory)) (zero? (system* "umount" target-directory))) -- cgit v1.2.3 From 6ffd11f129405c7bd663201096d8fcfcde6344a9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 18 May 2014 22:06:38 +0200 Subject: system: Prevent grub.cfg from being GC'd. * guix/build/install.scm (install-grub): Use 'copy-file' instead of 'symlink' for GRUB.CFG. --- guix/build/install.scm | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) (limited to 'guix/build') diff --git a/guix/build/install.scm b/guix/build/install.scm index 564735a7f6..f61c16f13a 100644 --- a/guix/build/install.scm +++ b/guix/build/install.scm @@ -38,11 +38,18 @@ (define-module (guix build install) (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))) + (let* ((target (string-append mount-point "/boot/grub/grub.cfg")) + (pivot (string-append target ".new"))) + (mkdir-p (dirname target)) + + ;; Copy GRUB.CFG instead of just symlinking it since it's not a GC root. + ;; Do that atomically. + (copy-file grub.cfg pivot) + (rename-file pivot target) + + (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 -- cgit v1.2.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 'guix/build') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 4bf0e06081..ee9ac81ce7 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -230,7 +230,8 @@ (define* (qemu-image #:key (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 e67b431b5a..cf661a33f3 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -121,7 +121,7 @@ (define* (initialize-partition-table device "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 @@ (define (graph-from-file file) (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 @@ (define* (initialize-hard-disk #:key 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 @@ (define target-directory (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 @@ (define target-store (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.2.3 From 9bea3b42b49434bccd9acd296569d2a874eddb6e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 20 May 2014 21:52:31 +0200 Subject: vm: Fix typo. Regression introduced in e38e18f. * guix/build/vm.scm (initialize-hard-disk)[partition]: Use a string. --- guix/build/vm.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix/build') diff --git a/guix/build/vm.scm b/guix/build/vm.scm index cf661a33f3..e3f6d27ee7 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -168,7 +168,7 @@ (define target-store (string-append target-directory (%store-directory))) (define partition - (string-append device 1)) + (string-append device "1")) (unless (initialize-partition-table device #:partition-size -- cgit v1.2.3 From eb7ccb1afaaa5db3a6c4fdec0a9f22919d100952 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 20 May 2014 21:56:20 +0200 Subject: linux-initrd: Display a backtrace when the initial program fails. * guix/build/linux-initrd.scm (boot-system): Add pre-unwind handler in 'catch' form around 'primitive-load', and call 'format' and 'display-backtrace' from there. --- guix/build/linux-initrd.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix/build') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 9093e72695..8db9f02caf 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -482,10 +482,12 @@ (define root-fs-type (catch #t (lambda () (primitive-load to-load)) + (lambda args + (start-repl)) (lambda args (format (current-error-port) "'~a' raised an exception: ~s~%" to-load args) - (start-repl))) + (display-backtrace (make-stack #t) (current-error-port)))) (format (current-error-port) "boot program '~a' terminated, rebooting~%" to-load) -- cgit v1.2.3 From d1f477199d649cbe33558ed218fa8063553decc3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 21 May 2014 23:19:13 +0200 Subject: vm: Remove misleading comment. * guix/build/vm.scm (load-in-linux-vm): Remove misleading comment. --- guix/build/vm.scm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'guix/build') diff --git a/guix/build/vm.scm b/guix/build/vm.scm index e3f6d27ee7..3c51ff8f34 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -94,8 +94,7 @@ (define* (load-in-linux-vm builder (error "qemu failed" qemu)) (if make-disk-image? - (copy-file "image.qcow2" ; XXX: who mkdir'd OUTPUT? - output) + (copy-file "image.qcow2" output) (begin (mkdir output) (copy-recursively "xchg" output)))) -- cgit v1.2.3 From 641f9a2a1f3a1ad0b4c3003a2efc5c7975286cc1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 21 May 2014 23:31:46 +0200 Subject: vm: Modularize build-side code. * guix/build/install.scm (install-grub): Call 'error' if 'system*' returns non-zero. * guix/build/vm.scm (initialize-partition-table): Make 'partition-size' a positional parameter. Call 'error' when 'system*' returns non-zero'. (format-partition, initialize-root-partition): New procedures. (initialize-hard-disk): Use them. --- guix/build/install.scm | 10 +++-- guix/build/vm.scm | 102 ++++++++++++++++++++++++++++--------------------- 2 files changed, 64 insertions(+), 48 deletions(-) (limited to 'guix/build') diff --git a/guix/build/install.scm b/guix/build/install.scm index f61c16f13a..663a87b4b5 100644 --- a/guix/build/install.scm +++ b/guix/build/install.scm @@ -37,7 +37,7 @@ (define-module (guix build install) (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." +MOUNT-POINT." (let* ((target (string-append mount-point "/boot/grub/grub.cfg")) (pivot (string-append target ".new"))) (mkdir-p (dirname target)) @@ -47,9 +47,11 @@ (define* (install-grub grub.cfg device mount-point) (copy-file grub.cfg pivot) (rename-file pivot target) - (zero? (system* "grub-install" "--no-floppy" - "--boot-directory" (string-append mount-point "/boot") - device)))) + (unless (zero? (system* "grub-install" "--no-floppy" + "--boot-directory" + (string-append mount-point "/boot") + device)) + (error "failed to install GRUB")))) (define (evaluate-populate-directive directive target) "Evaluate DIRECTIVE, an sexp describing a file or directory to create under diff --git a/guix/build/vm.scm b/guix/build/vm.scm index 3c51ff8f34..2a8843c633 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -25,6 +25,9 @@ (define-module (guix build vm) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (load-in-linux-vm + format-partition + initialize-root-partition + initialize-partition-table initialize-hard-disk)) ;;; Commentary: @@ -113,16 +116,20 @@ (define (read-reference-graph port) (loop (read-line port) result))))) -(define* (initialize-partition-table device +(define* (initialize-partition-table device partition-size #:key (label-type "msdos") - partition-size) + (offset (expt 2 20))) "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" device "mklabel" label-type - "mkpart" "primary" "ext2" "1MiB" - (format #f "~aB" partition-size)))) +partition of PARTITION-SIZE bytes starting at OFFSET bytes. Return #t on +success." + (format #t "creating partition table with a ~a B partition...\n" + partition-size) + (unless (zero? (system* "parted" device "mklabel" label-type + "mkpart" "primary" "ext2" + (format #f "~aB" offset) + (format #f "~aB" partition-size))) + (error "failed to create partition table"))) (define* (populate-store reference-graphs target) "Populate the store under directory TARGET with the items specified in @@ -146,43 +153,19 @@ (define (graph-from-file file) (define MS_BIND 4096) ; again! -(define* (initialize-hard-disk device - #:key - grub.cfg - disk-image-size - (file-system-type "ext4") - (closures '()) - copy-closures? - (register-closures? #t) - (directives '())) - "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 -further populate the partition." - (define target-directory - "/fs") +(define (format-partition partition type) + "Create a file system TYPE on PARTITION." + (format #t "creating ~a partition...\n" type) + (unless (zero? (system* (string-append "mkfs." type) "-F" partition)) + (error "failed to create partition"))) +(define* (initialize-root-partition target-directory + #:key copy-closures? register-closures? + closures) + "Initialize the root partition mounted at TARGET-DIRECTORY." (define target-store (string-append target-directory (%store-directory))) - (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" partition)) - (error "failed to create partition")) - - (display "mounting partition...\n") - (mkdir target-directory) - (mount partition target-directory file-system-type) - (when copy-closures? ;; Populate the store. (populate-store (map (cut string-append "/xchg/" <>) closures) @@ -207,12 +190,43 @@ (define partition (unless copy-closures? (system* "umount" target-store))) - ;; Evaluate the POPULATE directives. + ;; Add the non-store directories and files. (display "populating...\n") - (populate-root-file-system target-directory) + (populate-root-file-system target-directory)) + +(define* (initialize-hard-disk device + #:key + grub.cfg + disk-image-size + (file-system-type "ext4") + (closures '()) + copy-closures? + (register-closures? #t)) + "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." + (define target-directory + "/fs") + + (define partition + (string-append device "1")) + + (initialize-partition-table device + (- disk-image-size (* 5 (expt 2 20)))) + + (format-partition partition file-system-type) + + (display "mounting partition...\n") + (mkdir target-directory) + (mount partition target-directory file-system-type) + + (initialize-root-partition target-directory + #:copy-closures? copy-closures? + #:register-closures? register-closures? + #:closures closures) - (unless (install-grub grub.cfg device target-directory) - (error "failed to install GRUB")) + (install-grub grub.cfg device target-directory) ;; 'guix-register' resets timestamps and everything, so no need to do it ;; once more in that case. -- cgit v1.2.3 From 3035b50f28c1bcbc0a2bb09457a69ea9c06d69e0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 22 May 2014 21:57:39 +0200 Subject: linux-initrd: Build /dev/loop* nodes. * guix/build/linux-initrd.scm (make-essential-device-nodes): Build /dev/loop[0-7]. --- guix/build/linux-initrd.scm | 8 ++++++++ 1 file changed, 8 insertions(+) (limited to 'guix/build') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 8db9f02caf..5be3c1ac2a 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -168,6 +168,14 @@ (define (scope dir) (symlink "/proc/self/fd/1" (scope "dev/stdout")) (symlink "/proc/self/fd/2" (scope "dev/stderr")) + ;; Loopback devices. + (let loop ((i 0)) + (when (< i 8) + (mknod (scope (string-append "dev/loop" (number->string i))) + 'block-special #o660 + (device-number 7 i)) + (loop (+ 1 i)))) + ;; File systems in user space (FUSE). (mknod (scope "dev/fuse") 'char-special #o666 (device-number 10 229))) -- cgit v1.2.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 'guix/build') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 0d41791d87..39ce5bb6ef 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -119,6 +119,7 @@ (define* (expression->derivation-in-linux-vm name exp (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 @@ (define* (expression->derivation-in-linux-vm name exp 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 @@ (define builder #: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 @@ (define* (qemu-image #:key (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 @@ (define* (qemu-image #:key #: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 2a8843c633..4de536abb4 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -50,6 +50,7 @@ (define* (load-in-linux-vm builder (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 @@ (define* (load-in-linux-vm builder 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 @@ (define* (load-in-linux-vm builder "-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.2.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 'guix/build') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 39ce5bb6ef..7d0ffd971e 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -236,7 +236,7 @@ (define* (qemu-image #:key (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 4de536abb4..e559542f0a 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -96,7 +96,8 @@ (define image-file "-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.2.3 From a68d976b666a5097585cf221f4f8d793f90f3464 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 23 May 2014 22:19:37 +0200 Subject: download: Enlarge your receive buffer. * guix/build/download.scm (open-connection-for-uri): Remove call to 'setsockopt'. * guix/http-client.scm (open-socket-for-uri)[rmem-max, buffer-size]: New variables. Add call to 'setsockopt'. --- guix/build/download.scm | 2 -- guix/http-client.scm | 12 ++++++++++++ 2 files changed, 12 insertions(+), 2 deletions(-) (limited to 'guix/build') diff --git a/guix/build/download.scm b/guix/build/download.scm index 5d881b93ee..d98933a907 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -167,8 +167,6 @@ (define addresses ;; Buffer input and output on this port. (setvbuf s _IOFBF) - ;; Enlarge the receive buffer. - (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024)) (if (eq? 'https (uri-scheme uri)) (tls-wrap s) diff --git a/guix/http-client.scm b/guix/http-client.scm index 1f05df4b05..4770628e45 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -162,7 +162,19 @@ (define bad-response (define* (open-socket-for-uri uri #:key (buffered? #t)) "Return an open port for URI. When BUFFERED? is false, the returned port is unbuffered." + (define rmem-max + ;; The maximum size for a receive buffer on Linux, see socket(7). + "/proc/sys/net/core/rmem_max") + + (define buffer-size + (if (file-exists? rmem-max) + (call-with-input-file rmem-max read) + 126976)) ; the default for Linux, per 'rmem_default' + (let ((s ((@ (web client) open-socket-for-uri) uri))) + ;; Work around by restoring a decent + ;; buffer size. + (setsockopt s SOL_SOCKET SO_RCVBUF buffer-size) (unless buffered? (setvbuf s _IONBF)) s)) -- cgit v1.2.3 From 484a2b3a5ac7337e5d3b8773f6ce8c356b72742b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 24 May 2014 15:51:57 +0200 Subject: system: Separate the activation script from the boot script. * gnu/system.scm (operating-system-activation-script): New procedure, containing most of the former 'operating-system-boot-script'. (operating-system-boot-script): Call it, and 'primitive-load' its result. * guix/build/activation.scm (%booted-system): Remove. (activate-current-system): Remove #:boot? parameter and related code. --- gnu/system.scm | 27 ++++++++++++++++++++++----- guix/build/activation.scm | 18 ++++-------------- 2 files changed, 26 insertions(+), 19 deletions(-) (limited to 'guix/build') diff --git a/gnu/system.scm b/gnu/system.scm index 6cb7d303db..1d708179bd 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -348,9 +348,10 @@ (define (user-account->gexp 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." +(define (operating-system-activation-script os) + "Return the activation script for OS---i.e., the code that \"activates\" the +stateful part of OS, including user accounts and groups, special directories, +etc." (define %modules '((guix build activation) (guix build utils) @@ -360,7 +361,6 @@ (define %modules (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)) @@ -399,7 +399,24 @@ (define group-specs (activate-setuid-programs (list #$@setuid-progs)) ;; Set up /run/current-system. - (activate-current-system #:boot? #t) + (activate-current-system))))) + +(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." + (mlet* %store-monad ((services (operating-system-services os)) + (activate (operating-system-activation-script os)) + (dmd-conf (dmd-configuration-file services))) + (gexp->file "boot" + #~(begin + ;; Activate the system. + ;; TODO: Use 'load-compiled'. + (primitive-load #$activate) + + ;; Keep track of the booted system. + (false-if-exception (delete-file "/run/booted-system")) + (symlink (readlink "/run/current-system") + "/run/booted-system") ;; Close any remaining open file descriptors to be on the ;; safe side. This must be the very last thing we do, diff --git a/guix/build/activation.scm b/guix/build/activation.scm index 49f98c021d..62e69a9152 100644 --- a/guix/build/activation.scm +++ b/guix/build/activation.scm @@ -197,29 +197,19 @@ (define (make-setuid-program prog) (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. + ;; as the system we booted (aka. /run/booted-system) 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." +(define* (activate-current-system #:optional (system (boot-time-system))) + "Atomically make SYSTEM the current 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"))) -- cgit v1.2.3 From 517830cc0154dbe4a77741e7ee61703c194086a4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 24 May 2014 17:53:30 +0200 Subject: system: Always create /var/empty. * guix/build/install.scm (directives): Add /var/empty. --- guix/build/install.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix/build') diff --git a/guix/build/install.scm b/guix/build/install.scm index 663a87b4b5..24de954067 100644 --- a/guix/build/install.scm +++ b/guix/build/install.scm @@ -78,6 +78,7 @@ (define (directives store) (directory "/var/log") ; for dmd (directory "/var/run/nscd") (directory "/var/guix/gcroots") + (directory "/var/empty") ; for no-login accounts (directory "/run") ("/var/guix/gcroots/booted-system" -> "/run/booted-system") ("/var/guix/gcroots/current-system" -> "/run/current-system") -- cgit v1.2.3 From 4b2615e1cae8e21df8f180abf261d1dc22a2459e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 24 May 2014 18:09:11 +0200 Subject: services: nscd: Provide an 'activate' script to make /var/run/nscd. * gnu/services/base.scm (nscd-service): Add 'activate' field. * guix/build/install.scm (directives): Remove /var/run/nscd; add /var/run. * doc/guix.texi (Defining Services): Add 'activate' field in example. Document it. --- doc/guix.texi | 19 +++++++++++++------ gnu/services/base.scm | 5 +++++ guix/build/install.scm | 2 +- 3 files changed, 19 insertions(+), 7 deletions(-) (limited to 'guix/build') diff --git a/doc/guix.texi b/doc/guix.texi index ddb0763495..bd853e6eac 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3299,6 +3299,9 @@ like: (return (service (documentation "Run libc's name service cache daemon.") (provision '(nscd)) + (activate #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/run/nscd"))) (start #~(make-forkexec-constructor (string-append #$glibc "/sbin/nscd") "-f" "/dev/null" "--foreground")) @@ -3307,12 +3310,16 @@ like: @end lisp @noindent -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}, +The @code{activate}, @code{start}, and @code{stop} fields are G-expressions +(@pxref{G-Expressions}). The @code{activate} field contains a script to +run at ``activation'' time; it makes sure that the @file{/var/run/nscd} +directory exists before @command{nscd} is started. + +The @code{start} and @code{stop} fields 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}). diff --git a/gnu/services/base.scm b/gnu/services/base.scm index aec6050588..dc0161408b 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -225,6 +225,11 @@ (define* (nscd-service #:key (glibc glibc-final)) (documentation "Run libc's name service cache daemon (nscd).") (provision '(nscd)) (requirement '(user-processes)) + + (activate #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/run/nscd"))) + (start #~(make-forkexec-constructor (string-append #$glibc "/sbin/nscd") "-f" "/dev/null" diff --git a/guix/build/install.scm b/guix/build/install.scm index 24de954067..afa7d1dd8f 100644 --- a/guix/build/install.scm +++ b/guix/build/install.scm @@ -76,9 +76,9 @@ (define (directives store) `((directory ,store 0 0) (directory "/etc") (directory "/var/log") ; for dmd - (directory "/var/run/nscd") (directory "/var/guix/gcroots") (directory "/var/empty") ; for no-login accounts + (directory "/var/run") (directory "/run") ("/var/guix/gcroots/booted-system" -> "/run/booted-system") ("/var/guix/gcroots/current-system" -> "/run/current-system") -- cgit v1.2.3