From 735c6dd7faec036adbfa44d927c823ffa9ea1243 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 29 Jan 2014 13:04:00 +0100 Subject: gnu: Lower initrd makers from packages to monadic procedures. * gnu/packages/linux-initrd.scm: Remove. * gnu/system/linux-initrd.scm: New file. * gnu-system.am (GNU_SYSTEM_MODULES): Adjust accordingly. * gnu/system.scm (): Change default 'initrd' value to (gnu-system-initrd). (operating-system-derivation): Bind 'operating-system-initrd'. Pass 'menu-entry' an initrd file name instead of a package. * gnu/system/grub.scm (grub-configuration-file): Expect 'initrd' to be file name. --- gnu/system/grub.scm | 7 +- gnu/system/linux-initrd.scm | 360 ++++++++++++++++++++++++++++++++++++++++++++ gnu/system/vm.scm | 17 ++- 3 files changed, 372 insertions(+), 12 deletions(-) create mode 100644 gnu/system/linux-initrd.scm (limited to 'gnu/system') diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm index 86fa9b504..5dc0b85ff 100644 --- a/gnu/system/grub.scm +++ b/gnu/system/grub.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Ludovic Courtès +;;; Copyright © 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -41,7 +41,7 @@ (linux menu-entry-linux) (linux-arguments menu-entry-linux-arguments (default '())) - (initrd menu-entry-initrd)) + (initrd menu-entry-initrd)) ; file name of the initrd (define* (grub-configuration-file entries #:key (default-entry 1) (timeout 5) @@ -66,10 +66,7 @@ search.file ~a~%" (match-lambda (($ label linux arguments initrd) (mlet %store-monad ((linux (package-file linux "bzImage" - #:system system)) - (initrd (package-file initrd "initrd" #:system system))) - ;; XXX: Assume that INITRD is a directory containing an 'initrd' file. (return (format #f "menuentry ~s { linux ~a ~a initrd ~a diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm new file mode 100644 index 000000000..a28b913c3 --- /dev/null +++ b/gnu/system/linux-initrd.scm @@ -0,0 +1,360 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu system linux-initrd) + #:use-module (guix monads) + #:use-module (guix utils) + #:use-module (gnu packages cpio) + #:use-module (gnu packages compression) + #:use-module (gnu packages linux) + #:use-module (gnu packages guile) + #:use-module ((gnu packages make-bootstrap) + #:select (%guile-static-stripped)) + #:export (expression->initrd + qemu-initrd + gnu-system-initrd)) + + +;;; Commentary: +;;; +;;; Tools to build initial RAM disks (initrd's) for Linux-Libre, and in +;;; particular initrd's that run Guile. +;;; +;;; Code: + + +(define* (expression->initrd exp + #:key + (guile %guile-static-stripped) + (cpio cpio) + (gzip gzip) + (name "guile-initrd") + (system (%current-system)) + (modules '()) + (linux #f) + (linux-modules '())) + "Return a package that contains a Linux initrd (a gzipped cpio archive) +containing GUILE and that evaluates EXP upon booting. LINUX-MODULES is a list +of `.ko' file names to be copied from LINUX into the initrd. MODULES is a +list of Guile module names to be embedded in the initrd." + + ;; General Linux overview in `Documentation/early-userspace/README' and + ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'. + + (define builder + `(begin + (use-modules (guix build utils) + (ice-9 pretty-print) + (ice-9 popen) + (ice-9 match) + (ice-9 ftw) + (srfi srfi-26) + (system base compile) + (rnrs bytevectors) + ((system foreign) #:select (sizeof))) + + (let ((guile (assoc-ref %build-inputs "guile")) + (cpio (string-append (assoc-ref %build-inputs "cpio") + "/bin/cpio")) + (gzip (string-append (assoc-ref %build-inputs "gzip") + "/bin/gzip")) + (modules (assoc-ref %build-inputs "modules")) + (gos (assoc-ref %build-inputs "modules/compiled")) + (scm-dir (string-append "share/guile/" (effective-version))) + (go-dir (format #f ".cache/guile/ccache/~a-~a-~a-~a" + (effective-version) + (if (eq? (native-endianness) (endianness little)) + "LE" + "BE") + (sizeof '*) + (effective-version))) + (out (assoc-ref %outputs "out"))) + (mkdir out) + (mkdir "contents") + (with-directory-excursion "contents" + (copy-recursively guile ".") + (call-with-output-file "init" + (lambda (p) + (format p "#!/bin/guile -ds~%!#~%" guile) + (pretty-print ',exp p))) + (chmod "init" #o555) + (chmod "bin/guile" #o555) + + ;; Copy Guile modules. + (chmod scm-dir #o777) + (copy-recursively modules scm-dir + #:follow-symlinks? #t) + (copy-recursively gos (string-append "lib/guile/" + (effective-version) "/ccache") + #:follow-symlinks? #t) + + ;; Compile `init'. + (mkdir-p go-dir) + (set! %load-path (cons modules %load-path)) + (set! %load-compiled-path (cons gos %load-compiled-path)) + (compile-file "init" + #:opts %auto-compilation-options + #:output-file (string-append go-dir "/init.go")) + + ;; Copy Linux modules. + (let* ((linux (assoc-ref %build-inputs "linux")) + (module-dir (and linux + (string-append linux "/lib/modules")))) + (mkdir "modules") + ,@(map (lambda (module) + `(match (find-files module-dir ,module) + ((file) + (format #t "copying '~a'...~%" file) + (copy-file file (string-append "modules/" + ,module))) + (() + (error "module not found" ,module module-dir)) + ((_ ...) + (error "several modules by that name" + ,module module-dir)))) + linux-modules)) + + ;; Reset the timestamps of all the files that will make it in the + ;; initrd. + (for-each (cut utime <> 0 0 0 0) + (find-files "." ".*")) + + (system* cpio "--version") + (let ((pipe (open-pipe* OPEN_WRITE cpio "-o" + "-O" (string-append out "/initrd") + "-H" "newc" "--null"))) + (define print0 + (let ((len (string-length "./"))) + (lambda (file) + (format pipe "~a\0" (string-drop file len))))) + + ;; Note: as per `ramfs-rootfs-initramfs.txt', always add + ;; directory entries before the files that are inside of it: "The + ;; Linux kernel cpio extractor won't create files in a directory + ;; that doesn't exist, so the directory entries must go before + ;; the files that go in those directories." + (file-system-fold (const #t) + (lambda (file stat result) ; leaf + (print0 file)) + (lambda (dir stat result) ; down + (unless (string=? dir ".") + (print0 dir))) + (const #f) ; up + (const #f) ; skip + (const #f) + #f + ".") + + (and (zero? (close-pipe pipe)) + (with-directory-excursion out + (and (zero? (system* gzip "--best" "initrd")) + (rename-file "initrd.gz" "initrd"))))))))) + + (mlet* %store-monad + ((source (imported-modules modules)) + (compiled (compiled-modules modules)) + (inputs (lower-inputs + `(("guile" ,guile) + ("cpio" ,cpio) + ("gzip" ,gzip) + ("modules" ,source) + ("modules/compiled" ,compiled) + ,@(if linux + `(("linux" ,linux)) + '()))))) + (derivation-expression name builder + #:modules '((guix build utils)) + #:inputs inputs))) + +(define (qemu-initrd) + "Return a monadic derivation that builds an initrd for use in a QEMU guest +where the store is shared with the host." + (expression->initrd + '(begin + (use-modules (srfi srfi-1) + (srfi srfi-26) + (ice-9 match) + ((system base compile) #:select (compile-file)) + (guix build utils) + (guix build linux-initrd)) + + (display "Welcome, this is GNU's early boot Guile.\n") + (display "Use '--repl' for an initrd REPL.\n\n") + + (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"))) + + (when (member "--repl" args) + ((@ (system repl repl) start-repl))) + + (display "loading CIFS and companion modules...\n") + (for-each (compose load-linux-module* + (cut string-append "/modules/" <>)) + (list "md4.ko" "ecb.ko" "cifs.ko")) + + (unless (configure-qemu-networking) + (display "network interface is DOWN\n")) + + ;; Make /dev nodes. + (make-essential-device-nodes) + + ;; Prepare the real root file system under /root. + (unless (file-exists? "/root") + (mkdir "/root")) + (if root + (mount root "/root" "ext3") + (mount "none" "/root" "tmpfs")) + (mount-essential-file-systems #:root "/root") + + (mkdir-p "/root/xchg") + (mkdir-p "/root/nix/store") + + (unless (file-exists? "/root/dev") + (mkdir "/root/dev") + (make-essential-device-nodes #:root "/root")) + + ;; Mount the host's store and exchange directory. + (mount-qemu-smb-share "/store" "/root/nix/store") + (mount-qemu-smb-share "/xchg" "/root/xchg") + + ;; Copy the directories that contain .scm and .go files so that the + ;; child process in the chroot can load modules (we would bind-mount + ;; them but for some reason that fails with EINVAL -- XXX). + (mkdir-p "/root/share") + (mkdir-p "/root/lib") + (mount "none" "/root/share" "tmpfs") + (mount "none" "/root/lib" "tmpfs") + (copy-recursively "/share" "/root/share" + #:log (%make-void-port "w")) + (copy-recursively "/lib" "/root/lib" + #:log (%make-void-port "w")) + + + (if to-load + (letrec ((resolve + (lambda (file) + ;; If FILE is a symlink to an absolute file name, + ;; resolve it as if we were under /root. + (let ((st (lstat file))) + (if (eq? 'symlink (stat:type st)) + (let ((target (readlink file))) + (resolve (string-append "/root" target))) + file))))) + (format #t "loading boot file '~a'...\n" to-load) + (compile-file (resolve (string-append "/root/" to-load)) + #:output-file "/root/loader.go" + #:opts %auto-compilation-options) + (match (primitive-fork) + (0 + (chroot "/root") + (load-compiled "/loader.go") + + ;; TODO: Remove /lib, /share, and /loader.go. + ) + (pid + (format #t "boot file loaded under PID ~a~%" pid) + (let ((status (waitpid pid))) + (reboot))))) + (begin + (display "no boot file passed via '--load'\n") + (display "entering a warm and cozy REPL\n") + ((@ (system repl repl) start-repl)))))) + #:name "qemu-initrd" + #:modules '((guix build utils) + (guix build linux-initrd)) + #:linux linux-libre + #:linux-modules '("cifs.ko" "md4.ko" "ecb.ko"))) + +(define (gnu-system-initrd) + "Initrd for the GNU system itself, with nothing QEMU-specific." + (expression->initrd + '(begin + (use-modules (srfi srfi-1) + (srfi srfi-26) + (ice-9 match) + (guix build utils) + (guix build linux-initrd)) + + (display "Welcome, this is GNU's early boot Guile.\n") + (display "Use '--repl' for an initrd REPL.\n\n") + + (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"))) + + (when (member "--repl" args) + ((@ (system repl repl) start-repl))) + + ;; Make /dev nodes. + (make-essential-device-nodes) + + ;; Prepare the real root file system under /root. + (mkdir-p "/root") + (if root + ;; Assume ROOT has a usable /dev tree. + (mount root "/root" "ext3") + (begin + (mount "none" "/root" "tmpfs") + (make-essential-device-nodes #:root "/root"))) + + (mount-essential-file-systems #:root "/root") + + (mkdir-p "/root/tmp") + (mount "none" "/root/tmp" "tmpfs") + + ;; XXX: We don't copy our fellow Guile modules to /root (see + ;; 'qemu-initrd'), so if TO-LOAD tries to load a module (which can + ;; happen if it throws, to display the exception!), then we're + ;; screwed. Hopefully TO-LOAD is a simple expression that just does + ;; '(execlp ...)'. + + (if to-load + (begin + (format #t "loading '~a'...\n" to-load) + (chroot "/root") + (primitive-load to-load) + (format (current-error-port) + "boot program '~a' terminated, rebooting~%" + to-load) + (sleep 2) + (reboot)) + (begin + (display "no init file passed via '--load'\n") + (display "entering a warm and cozy REPL\n") + ((@ (system repl repl) start-repl)))))) + #:name "qemu-system-initrd" + #:modules '((guix build linux-initrd) + (guix build utils)) + #:linux linux-libre)) + +;;; linux-initrd.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index e75c09d85..fa9365414 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Ludovic Courtès +;;; Copyright © 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -35,7 +35,6 @@ #:use-module (gnu packages zile) #:use-module (gnu packages grub) #:use-module (gnu packages linux) - #:use-module (gnu packages linux-initrd) #:use-module (gnu packages package-management) #:use-module ((gnu packages make-bootstrap) #:select (%guile-static-stripped)) @@ -43,6 +42,7 @@ #:use-module (gnu system shadow) #:use-module (gnu system linux) + #:use-module (gnu system linux-initrd) #:use-module (gnu system grub) #:use-module (gnu system dmd) #:use-module (gnu system) @@ -67,7 +67,7 @@ (system (%current-system)) (inputs '()) (linux linux-libre) - (initrd qemu-initrd) + initrd (qemu qemu/smb-shares) (env-vars '()) (modules '()) @@ -78,10 +78,10 @@ (references-graphs #f) (disk-image-size (* 100 (expt 2 20)))) - "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD. In the -virtual machine, EXP has access to all of INPUTS from the store; it should put -its output files in the `/xchg' directory, which is copied to the derivation's -output when the VM terminates. + "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a +derivation). In the virtual machine, EXP has access to all of INPUTS from the +store; it should put its output files in the `/xchg' directory, which is +copied to the derivation's output when the VM terminates. When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of DISK-IMAGE-SIZE bytes and return it. @@ -178,6 +178,9 @@ made available under the /xchg CIFS share." (user-builder (text-file "builder-in-linux-vm" (object->string exp*))) (coreutils -> (car (assoc-ref %final-inputs "coreutils"))) + (initrd (if initrd + (return initrd) + (qemu-initrd))) ; default initrd (inputs (lower-inputs `(("qemu" ,qemu) ("linux" ,linux) ("initrd" ,initrd) -- cgit v1.3 From d4254711821f7df93e33aa4a3f6484b901c7b5e3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 29 Jan 2014 21:57:56 +0100 Subject: gnu: linux-initrd: Factorize boot code. * guix/build/linux-initrd.scm (boot-system): New procedure. * gnu/system/linux-initrd.scm (qemu-initrd): Add keyword parameters 'guile-modules-in-chroot?' and 'mounts'. Change builder to simply call 'boot-system'. (gnu-system-initrd): Change to a simple call to 'qemu-initrd'. * gnu/system/vm.scm (expression->derivation-in-linux-vm): Call 'qemu-initrd' with #:guile-modules-in-chroot?. --- gnu/system/linux-initrd.scm | 192 +++++++------------------------------------- gnu/system/vm.scm | 4 +- guix/build/linux-initrd.scm | 121 +++++++++++++++++++++++++++- 3 files changed, 152 insertions(+), 165 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index a28b913c3..ea9d708da 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -19,6 +19,8 @@ (define-module (gnu system linux-initrd) #:use-module (guix monads) #:use-module (guix utils) + #:use-module ((guix store) + #:select (%store-prefix)) #:use-module (gnu packages cpio) #:use-module (gnu packages compression) #:use-module (gnu packages linux) @@ -181,180 +183,46 @@ list of Guile module names to be embedded in the initrd." #:modules '((guix build utils)) #:inputs inputs))) -(define (qemu-initrd) +(define* (qemu-initrd #:key + guile-modules-in-chroot? + (mounts `((cifs "/store" ,(%store-prefix)) + (cifs "/xchg" "/xchg")))) "Return a monadic derivation that builds an initrd for use in a QEMU guest -where the store is shared with the host." - (expression->initrd - '(begin - (use-modules (srfi srfi-1) - (srfi srfi-26) - (ice-9 match) - ((system base compile) #:select (compile-file)) - (guix build utils) - (guix build linux-initrd)) - - (display "Welcome, this is GNU's early boot Guile.\n") - (display "Use '--repl' for an initrd REPL.\n\n") - - (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"))) - - (when (member "--repl" args) - ((@ (system repl repl) start-repl))) - - (display "loading CIFS and companion modules...\n") - (for-each (compose load-linux-module* - (cut string-append "/modules/" <>)) - (list "md4.ko" "ecb.ko" "cifs.ko")) - - (unless (configure-qemu-networking) - (display "network interface is DOWN\n")) +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: - ;; Make /dev nodes. - (make-essential-device-nodes) + (FILE-SYSTEM-TYPE SOURCE TARGET) - ;; Prepare the real root file system under /root. - (unless (file-exists? "/root") - (mkdir "/root")) - (if root - (mount root "/root" "ext3") - (mount "none" "/root" "tmpfs")) - (mount-essential-file-systems #:root "/root") +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!)." + (define cifs-modules + ;; Modules needed to mount CIFS file systems. + '("md4.ko" "ecb.ko" "cifs.ko")) - (mkdir-p "/root/xchg") - (mkdir-p "/root/nix/store") + (define linux-modules + ;; Modules added to the initrd and loaded from the initrd. + (if (assoc-ref mounts 'cifs) + cifs-modules + '())) - (unless (file-exists? "/root/dev") - (mkdir "/root/dev") - (make-essential-device-nodes #:root "/root")) - - ;; Mount the host's store and exchange directory. - (mount-qemu-smb-share "/store" "/root/nix/store") - (mount-qemu-smb-share "/xchg" "/root/xchg") - - ;; Copy the directories that contain .scm and .go files so that the - ;; child process in the chroot can load modules (we would bind-mount - ;; them but for some reason that fails with EINVAL -- XXX). - (mkdir-p "/root/share") - (mkdir-p "/root/lib") - (mount "none" "/root/share" "tmpfs") - (mount "none" "/root/lib" "tmpfs") - (copy-recursively "/share" "/root/share" - #:log (%make-void-port "w")) - (copy-recursively "/lib" "/root/lib" - #:log (%make-void-port "w")) - - - (if to-load - (letrec ((resolve - (lambda (file) - ;; If FILE is a symlink to an absolute file name, - ;; resolve it as if we were under /root. - (let ((st (lstat file))) - (if (eq? 'symlink (stat:type st)) - (let ((target (readlink file))) - (resolve (string-append "/root" target))) - file))))) - (format #t "loading boot file '~a'...\n" to-load) - (compile-file (resolve (string-append "/root/" to-load)) - #:output-file "/root/loader.go" - #:opts %auto-compilation-options) - (match (primitive-fork) - (0 - (chroot "/root") - (load-compiled "/loader.go") + (expression->initrd + `(begin + (use-modules (guix build linux-initrd)) - ;; TODO: Remove /lib, /share, and /loader.go. - ) - (pid - (format #t "boot file loaded under PID ~a~%" pid) - (let ((status (waitpid pid))) - (reboot))))) - (begin - (display "no boot file passed via '--load'\n") - (display "entering a warm and cozy REPL\n") - ((@ (system repl repl) start-repl)))))) + (boot-system #:mounts ',mounts + #:linux-modules ',linux-modules + #:qemu-guest-networking? #t + #:guile-modules-in-chroot? ',guile-modules-in-chroot?)) #:name "qemu-initrd" #:modules '((guix build utils) (guix build linux-initrd)) #:linux linux-libre - #:linux-modules '("cifs.ko" "md4.ko" "ecb.ko"))) + #:linux-modules linux-modules)) (define (gnu-system-initrd) "Initrd for the GNU system itself, with nothing QEMU-specific." - (expression->initrd - '(begin - (use-modules (srfi srfi-1) - (srfi srfi-26) - (ice-9 match) - (guix build utils) - (guix build linux-initrd)) - - (display "Welcome, this is GNU's early boot Guile.\n") - (display "Use '--repl' for an initrd REPL.\n\n") - - (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"))) - - (when (member "--repl" args) - ((@ (system repl repl) start-repl))) - - ;; Make /dev nodes. - (make-essential-device-nodes) - - ;; Prepare the real root file system under /root. - (mkdir-p "/root") - (if root - ;; Assume ROOT has a usable /dev tree. - (mount root "/root" "ext3") - (begin - (mount "none" "/root" "tmpfs") - (make-essential-device-nodes #:root "/root"))) - - (mount-essential-file-systems #:root "/root") - - (mkdir-p "/root/tmp") - (mount "none" "/root/tmp" "tmpfs") - - ;; XXX: We don't copy our fellow Guile modules to /root (see - ;; 'qemu-initrd'), so if TO-LOAD tries to load a module (which can - ;; happen if it throws, to display the exception!), then we're - ;; screwed. Hopefully TO-LOAD is a simple expression that just does - ;; '(execlp ...)'. - - (if to-load - (begin - (format #t "loading '~a'...\n" to-load) - (chroot "/root") - (primitive-load to-load) - (format (current-error-port) - "boot program '~a' terminated, rebooting~%" - to-load) - (sleep 2) - (reboot)) - (begin - (display "no init file passed via '--load'\n") - (display "entering a warm and cozy REPL\n") - ((@ (system repl repl) start-repl)))))) - #:name "qemu-system-initrd" - #:modules '((guix build linux-initrd) - (guix build utils)) - #:linux linux-libre)) + (qemu-initrd #:guile-modules-in-chroot? #f)) ;;; linux-initrd.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index fa9365414..151535303 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -178,9 +178,9 @@ made available under the /xchg CIFS share." (user-builder (text-file "builder-in-linux-vm" (object->string exp*))) (coreutils -> (car (assoc-ref %final-inputs "coreutils"))) - (initrd (if initrd + (initrd (if initrd ; use the default initrd? (return initrd) - (qemu-initrd))) ; default initrd + (qemu-initrd #:guile-modules-in-chroot? #t))) (inputs (lower-inputs `(("qemu" ,qemu) ("linux" ,linux) ("initrd" ,initrd) diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index ae18a16e1..039a60acf 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -19,6 +19,12 @@ (define-module (guix build linux-initrd) #:use-module (rnrs io ports) #:use-module (system foreign) + #:autoload (system repl repl) (start-repl) + #:autoload (system base compile) (compile-file) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:use-module (guix build utils) #:export (mount-essential-file-systems linux-command-line make-essential-device-nodes @@ -26,7 +32,8 @@ mount-qemu-smb-share bind-mount load-linux-module* - device-number)) + device-number + boot-system)) ;;; Commentary: ;;; @@ -151,4 +158,116 @@ Vanilla QEMU's `-smb' option just exports a /qemu share, whereas our the last argument of `mknod'." (+ (* major 256) minor)) +(define* (boot-system #:key + (linux-modules '()) + qemu-guest-networking? + guile-modules-in-chroot? + (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 +QEMU-GUEST-NETWORKING? is true, mounting the file systems specified in MOUNTS, +and finally booting into the new root if any. The initrd supports kernel +command-line options '--load', '--root', and '--repl'. + +MOUNTS must be a list of elements of the form: + + (FILE-SYSTEM-TYPE SOURCE TARGET) + +When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in +the new root." + (define (resolve file) + ;; If FILE is a symlink to an absolute file name, resolve it as if we were + ;; under /root. + (let ((st (lstat file))) + (if (eq? 'symlink (stat:type st)) + (let ((target (readlink file))) + (resolve (string-append "/root" target))) + file))) + + (display "Welcome, this is GNU's early boot Guile.\n") + (display "Use '--repl' for an initrd REPL.\n\n") + + (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"))) + + (when (member "--repl" args) + (start-repl)) + + (display "loading kernel modules...\n") + (for-each (compose load-linux-module* + (cut string-append "/modules/" <>)) + linux-modules) + + (when qemu-guest-networking? + (unless (configure-qemu-networking) + (display "network interface is DOWN\n"))) + + ;; Make /dev nodes. + (make-essential-device-nodes) + + ;; Prepare the real root file system under /root. + (unless (file-exists? "/root") + (mkdir "/root")) + (if root + (mount root "/root" "ext3") + (mount "none" "/root" "tmpfs")) + (mount-essential-file-systems #:root "/root") + + (unless (file-exists? "/root/dev") + (mkdir "/root/dev") + (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))) + ;; TODO: Add 9p. + ) + mounts) + + (when guile-modules-in-chroot? + ;; Copy the directories that contain .scm and .go files so that the + ;; child process in the chroot can load modules (we would bind-mount + ;; them but for some reason that fails with EINVAL -- XXX). + (mkdir-p "/root/share") + (mkdir-p "/root/lib") + (mount "none" "/root/share" "tmpfs") + (mount "none" "/root/lib" "tmpfs") + (copy-recursively "/share" "/root/share" + #:log (%make-void-port "w")) + (copy-recursively "/lib" "/root/lib" + #:log (%make-void-port "w"))) + + (if to-load + (begin + (format #t "loading '~a'...\n" to-load) + (chroot "/root") + ;; TODO: Remove /lib, /share, and /loader.go. + (catch #t + (lambda () + (primitive-load to-load)) + (lambda args + (format (current-error-port) "'~a' raised an exception: ~s~%" + to-load args) + (start-repl))) + (format (current-error-port) + "boot program '~a' terminated, rebooting~%" + to-load) + (sleep 2) + (reboot)) + (begin + (display "no boot file passed via '--load'\n") + (display "entering a warm and cozy REPL\n") + (start-repl))))) + ;;; linux-initrd.scm ends here -- cgit v1.3 From a7d46f12ac4f87ff3981a8f8ee14d700799d49ef Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 30 Jan 2014 23:32:22 +0100 Subject: gnu: vm: Run QEMU with '-enable-kvm'. * gnu/system/vm.scm (expression->derivation-in-linux-vm): Pass QEMU '-enable-kvm'. --- gnu/system/vm.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 151535303..bd7718a14 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -154,7 +154,7 @@ made available under the /xchg CIFS share." (#f '()))) (and (zero? - (system* qemu "-nographic" "-no-reboot" + (system* qemu "-enable-kvm" "-nographic" "-no-reboot" "-net" "nic,model=e1000" "-net" (string-append "user,smb=" (getcwd)) "-kernel" linux @@ -188,6 +188,7 @@ made available under the /xchg CIFS share." ("builder" ,user-builder) ,@inputs)))) (derivation-expression name builder + ;; TODO: Require the "kvm" feature. #:system system #:inputs inputs #:env-vars env-vars -- cgit v1.3 From fc4bc4b6debecf9acc7e86ecb519c03b5b598bc4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 31 Jan 2014 01:43:16 +0100 Subject: gnu: linux-initrd: Properly distinguish between /dev/sda* and /dev/vda*. * guix/build/linux-initrd.scm (make-essential-device-nodes): Rename devices with major = 8 to /dev/sda*. Make /dev/vda* devices. * gnu/system/vm.scm (qemu-image): Change '/dev/vda' to '/dev/sda'. * gnu/system.scm (operating-system-derivation): Likewise. --- gnu/system.scm | 2 +- gnu/system/vm.scm | 8 ++++---- guix/build/linux-initrd.scm | 13 +++++++++---- 3 files changed, 14 insertions(+), 9 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system.scm b/gnu/system.scm index 5fb4a7483..e9ecfd273 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -330,7 +330,7 @@ alias ll='ls -l' (package-full-name kernel) " (technology preview)")) (linux kernel) - (linux-arguments `("--root=/dev/vda1" + (linux-arguments `("--root=/dev/sda1" ,(string-append "--load=" boot))) (initrd initrd-file)))) (grub.cfg (grub-configuration-file entries)) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index bd7718a14..540752265 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -294,18 +294,18 @@ such as /etc files." (assoc-ref %build-inputs "gawk") "/bin")) (display "creating partition table...\n") - (and (zero? (system* parted "/dev/vda" "mklabel" "msdos" + (and (zero? (system* parted "/dev/sda" "mklabel" "msdos" "mkpart" "primary" "ext2" "1MiB" ,(format #f "~aB" (- disk-image-size (* 5 (expt 2 20)))))) (begin (display "creating ext3 partition...\n") - (and (zero? (system* mkfs "-F" "/dev/vda1")) + (and (zero? (system* mkfs "-F" "/dev/sda1")) (let ((store (string-append "/fs" ,%store-directory))) (display "mounting partition...\n") (mkdir "/fs") - (mount "/dev/vda1" "/fs" "ext3") + (mount "/dev/sda1" "/fs" "ext3") (mkdir-p "/fs/boot/grub") (symlink grub.cfg "/fs/boot/grub/grub.cfg") @@ -379,7 +379,7 @@ such as /etc files." (and (zero? (system* grub "--no-floppy" "--boot-directory" "/fs/boot" - "/dev/vda")) + "/dev/sda")) (zero? (system* umount "/fs")) (reboot)))))))) #:system system diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 69cb58763..b9fc9b152 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -81,10 +81,15 @@ (unless (file-exists? (scope "dev")) (mkdir (scope "dev"))) - ;; Make the device nodes for QEMU's hard disk and partitions. - (mknod (scope "dev/vda") 'block-special #o644 (device-number 8 0)) - (mknod (scope "dev/vda1") 'block-special #o644 (device-number 8 1)) - (mknod (scope "dev/vda2") 'block-special #o644 (device-number 8 2)) + ;; Make the device nodes for SCSI disks. + (mknod (scope "dev/sda") 'block-special #o644 (device-number 8 0)) + (mknod (scope "dev/sda1") 'block-special #o644 (device-number 8 1)) + (mknod (scope "dev/sda2") 'block-special #o644 (device-number 8 2)) + + ;; The virtio (para-virtualized) block devices, as supported by QEMU/KVM. + (mknod (scope "dev/vda") 'block-special #o644 (device-number 252 0)) + (mknod (scope "dev/vda1") 'block-special #o644 (device-number 252 1)) + (mknod (scope "dev/vda2") 'block-special #o644 (device-number 252 2)) ;; TTYs. (mknod (scope "dev/tty") 'char-special #o600 -- cgit v1.3 From 217b862f0e8dfac18874f9c6ec8cafdb2471b4fb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 31 Jan 2014 12:01:23 +0100 Subject: gnu: linux-initrd: Match kernel module file names exactly. * gnu/system/linux-initrd.scm (expression->initrd)[string->regexp]: New procedure. Use it in the call to 'find-files'. --- gnu/system/linux-initrd.scm | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'gnu/system') diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index ea9d708da..408fb9f21 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -27,6 +27,7 @@ #:use-module (gnu packages guile) #:use-module ((gnu packages make-bootstrap) #:select (%guile-static-stripped)) + #:use-module (ice-9 regex) #:export (expression->initrd qemu-initrd gnu-system-initrd)) @@ -58,6 +59,10 @@ list of Guile module names to be embedded in the initrd." ;; General Linux overview in `Documentation/early-userspace/README' and ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'. + (define (string->regexp str) + ;; Return a regexp that matches STR exactly. + (string-append "^" (regexp-quote str) "$")) + (define builder `(begin (use-modules (guix build utils) @@ -119,7 +124,8 @@ list of Guile module names to be embedded in the initrd." (string-append linux "/lib/modules")))) (mkdir "modules") ,@(map (lambda (module) - `(match (find-files module-dir ,module) + `(match (find-files module-dir + ,(string->regexp module)) ((file) (format #t "copying '~a'...~%" file) (copy-file file (string-append "modules/" -- cgit v1.3 From 4919d68432c69d386300053b0de178f9efb0334f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 31 Jan 2014 12:21:10 +0100 Subject: gnu: linux-initrd: Recognize 9p file systems. * gnu/system/linux-initrd.scm (qemu-initrd)[virtio-9p-modules]: New variable. [linux-modules]: Append VIRTIO-9P-MODULES when a 9p file system is in MOUNTS. * guix/build/linux-initrd.scm (mount-qemu-9p): New procedure. (boot-system): Recognize '9p' in MOUNTS, and use 'mount-qemu-9p'. --- gnu/system/linux-initrd.scm | 15 ++++++++++++--- guix/build/linux-initrd.scm | 18 ++++++++++++++++-- 2 files changed, 28 insertions(+), 5 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 408fb9f21..1cc1d3b14 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -207,11 +207,20 @@ exception and backtrace!)." ;; Modules needed to mount CIFS file systems. '("md4.ko" "ecb.ko" "cifs.ko")) + (define virtio-9p-modules + ;; Modules for the 9p paravirtualized file system. + '("9pnet.ko" "9p.ko" "9pnet_virtio.ko")) + (define linux-modules ;; Modules added to the initrd and loaded from the initrd. - (if (assoc-ref mounts 'cifs) - cifs-modules - '())) + `("virtio.ko" "virtio_ring.ko" "virtio_pci.ko" + "virtio_balloon.ko" "virtio_blk.ko" "virtio_net.ko" + ,@(if (assoc-ref mounts 'cifs) + cifs-modules + '()) + ,@(if (assoc-ref mounts '9p) + virtio-9p-modules + '()))) (expression->initrd `(begin diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index b9fc9b152..7b22354f7 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -30,6 +30,7 @@ make-essential-device-nodes configure-qemu-networking mount-qemu-smb-share + mount-qemu-9p bind-mount load-linux-module* device-number @@ -145,6 +146,17 @@ Vanilla QEMU's `-smb' option just exports a /qemu share, whereas our (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")))) + (define (bind-mount source target) "Bind-mount SOURCE at TARGET." (define MS_BIND 4096) ; from libc's @@ -242,8 +254,10 @@ the new root." (let ((target (string-append "/root/" target))) (mkdir-p target) (mount-qemu-smb-share source target))) - ;; TODO: Add 9p. - ) + (('9p source target) + (let ((target (string-append "/root/" target))) + (mkdir-p target) + (mount-qemu-9p source target)))) mounts) (when guile-modules-in-chroot? -- cgit v1.3 From 44ddf33ed5b86fd79921aba5572a82c2a940808c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 31 Jan 2014 14:26:30 +0100 Subject: gnu: linux-initrd: Allow the root file system to be volatile. * gnu/system/linux-initrd.scm (qemu-initrd): Add 'volatile-root?' parameter. * guix/build/linux-initrd.scm (boot-system): Likewise. Honor it. --- gnu/system/linux-initrd.scm | 9 +++++++-- guix/build/linux-initrd.scm | 35 +++++++++++++++++++++++++++++++++-- 2 files changed, 40 insertions(+), 4 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 1cc1d3b14..9520473d0 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -191,6 +191,7 @@ list of Guile module names to be embedded in the initrd." (define* (qemu-initrd #:key guile-modules-in-chroot? + volatile-root? (mounts `((cifs "/store" ,(%store-prefix)) (cifs "/xchg" "/xchg")))) "Return a monadic derivation that builds an initrd for use in a QEMU guest @@ -202,7 +203,10 @@ be mounted atop the root file system, where each item has the form: 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!)." +exception and backtrace!). + +When VOLATILE-ROOT? is true, the root file system is writable but any changes +to it are lost." (define cifs-modules ;; Modules needed to mount CIFS file systems. '("md4.ko" "ecb.ko" "cifs.ko")) @@ -229,7 +233,8 @@ exception and backtrace!)." (boot-system #:mounts ',mounts #:linux-modules ',linux-modules #:qemu-guest-networking? #t - #:guile-modules-in-chroot? ',guile-modules-in-chroot?)) + #:guile-modules-in-chroot? ',guile-modules-in-chroot? + #:volatile-root? ',volatile-root?)) #:name "qemu-initrd" #:modules '((guix build utils) (guix build linux-initrd)) diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 7b22354f7..d317f850f 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -24,6 +24,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 match) + #:use-module (ice-9 ftw) #:use-module (guix build utils) #:export (mount-essential-file-systems linux-command-line @@ -179,6 +180,7 @@ the last argument of `mknod'." (linux-modules '()) qemu-guest-networking? guile-modules-in-chroot? + 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 @@ -191,7 +193,10 @@ MOUNTS must be a list of elements of the form: (FILE-SYSTEM-TYPE SOURCE TARGET) When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in -the new root." +the new root. + +When VOLATILE-ROOT? is true, the root file system is writable but any changes +to it are lost." (define (resolve file) ;; If FILE is a symlink to an absolute file name, resolve it as if we were ;; under /root. @@ -201,6 +206,8 @@ the new root." (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") @@ -236,12 +243,36 @@ the new root." (if root (catch #t (lambda () - (mount root "/root" "ext3")) + (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. + ) + (mount root "/root" "ext3"))) (lambda args (format (current-error-port) "exception while mounting '~a': ~s~%" root args) (start-repl))) (mount "none" "/root" "tmpfs")) + (mount-essential-file-systems #:root "/root") (unless (file-exists? "/root/dev") -- cgit v1.3 From fd3bfc44ff65e166d1c515721c7870391dceb799 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 31 Jan 2014 14:36:48 +0100 Subject: gnu: vm: Add support for running a VM that shares its store with the host. * gnu/system/vm.scm (qemu-image): Check whether GUIX is #f. (operating-system-build-gid, operating-system-default-contents): New procedures. (system-qemu-image): Use 'operating-system-build-gid'. (system-qemu-image/shared-store, system-qemu-image/shared-store-script): New procedures. * gnu/system.scm: Add missing exports. --- gnu/system.scm | 10 +++++ gnu/system/vm.scm | 125 ++++++++++++++++++++++++++++++++++++++++++++---------- 2 files changed, 113 insertions(+), 22 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system.scm b/gnu/system.scm index e9ecfd273..afea97616 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -38,6 +38,16 @@ operating-system? operating-system-services operating-system-packages + operating-system-bootloader-entries + operating-system-host-name + operating-system-kernel + operating-system-initrd + operating-system-users + operating-system-groups + operating-system-packages + operating-system-timezone + operating-system-locale + operating-system-services operating-system-derivation)) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 540752265..f36cfd031 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -53,7 +53,9 @@ #:export (expression->derivation-in-linux-vm qemu-image - system-qemu-image)) + system-qemu-image + system-qemu-image/shared-store + system-qemu-image/shared-store-script)) ;;; Commentary: @@ -323,8 +325,9 @@ such as /etc files." ;; Optionally, register the inputs in the image's store. (let* ((guix (assoc-ref %build-inputs "guix")) - (register (string-append guix - "/sbin/guix-register"))) + (register (and guix + (string-append guix + "/sbin/guix-register")))) ,@(if initialize-store? (match inputs-to-copy (((graph-files . _) ...) @@ -441,6 +444,35 @@ such as /etc files." tzdata guix)))) +(define (operating-system-build-gid os) + "Return as a monadic value the group id for build users of OS, or #f." + (anym %store-monad + (lambda (service) + (and (equal? '(guix-daemon) + (service-provision service)) + (match (service-user-groups service) + ((group) + (user-group-id group))))) + (operating-system-services os))) + +(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)) + (os-dir -> (derivation->output-path os-drv)) + (build-user-gid (operating-system-build-gid os))) + (return `((directory "/nix/store" 0 ,(or build-user-gid 0)) + (directory "/etc") + (directory "/var/log") ; for dmd + (directory "/var/run/nscd") + (directory "/var/nix/gcroots") + ("/var/nix/gcroots/system" -> ,os-dir) + (directory "/tmp") + (directory "/var/nix/profiles/per-user/root" 0 0) + (directory "/var/nix/profiles/per-user/guest" + 1000 100) + (directory "/home/guest" 1000 100))))) + (define* (system-qemu-image #:optional (os %demo-operating-system) #:key (disk-image-size (* 900 (expt 2 20)))) "Return the derivation of a QEMU image of DISK-IMAGE-SIZE bytes of the GNU @@ -449,29 +481,78 @@ system as described by OS." ((os-drv (operating-system-derivation os)) (os-dir -> (derivation->output-path os-drv)) (grub.cfg -> (string-append os-dir "/grub.cfg")) - (build-user-gid (anym %store-monad ; XXX - (lambda (service) - (and (equal? '(guix-daemon) - (service-provision service)) - (match (service-user-groups service) - ((group) - (user-group-id group))))) - (operating-system-services os))) - (populate -> `((directory "/nix/store" 0 ,build-user-gid) - (directory "/etc") - (directory "/var/log") ; for dmd - (directory "/var/run/nscd") - (directory "/var/nix/gcroots") - ("/var/nix/gcroots/system" -> ,os-dir) - (directory "/tmp") - (directory "/var/nix/profiles/per-user/root" 0 0) - (directory "/var/nix/profiles/per-user/guest" - 1000 100) - (directory "/home/guest" 1000 100)))) + (populate (operating-system-default-contents os))) (qemu-image #:grub-configuration grub.cfg #:populate populate #:disk-image-size disk-image-size #:initialize-store? #t #:inputs-to-copy `(("system" ,os-drv))))) +(define* (system-qemu-image/shared-store + #:optional (os %demo-operating-system) + #:key (disk-image-size (* 15 (expt 2 20)))) + "Return a derivation that builds a QEMU image of OS that shares its 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))) + ;; 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))) + +(define* (system-qemu-image/shared-store-script + #:optional (os %demo-operating-system) + #:key + (qemu (package (inherit qemu) + ;; FIXME/TODO: Use 9p instead of this hack. + (source (package-source qemu/smb-shares)))) + (graphic? #t)) + "Return a derivation that builds a script to run a virtual machine image of +OS that shares its store with the host." + (let* ((initrd (qemu-initrd #:mounts `((cifs "/store" ,(%store-prefix))) + #:volatile-root? #t)) + (os (operating-system (inherit os) (initrd initrd)))) + (define builder + (mlet %store-monad ((image (system-qemu-image/shared-store os)) + (qemu (package-file qemu + "bin/qemu-system-x86_64")) + (bash (package-file bash "bin/sh")) + (kernel (package-file (operating-system-kernel os) + "bzImage")) + (initrd initrd) + (os-drv (operating-system-derivation os))) + (return `(let ((out (assoc-ref %outputs "out"))) + (call-with-output-file out + (lambda (port) + (display + (string-append "#!" ,bash " +# TODO: -virtfs local,path=XXX,security_model=none,mount_tag=store +exec " ,qemu " -enable-kvm -no-reboot -net nic,model=virtio \ + -net user,smb=$PWD \ + -kernel " ,kernel " -initrd " + ,(string-append (derivation->output-path initrd) "/initrd") " \ +-append \"" ,(if graphic? "" "console=ttyS0 ") +"--load=" ,(derivation->output-path os-drv) "/boot --root=/dev/vda1\" \ + -drive file=" ,(derivation->output-path image) + ",if=virtio,cache=writeback,werror=report,readonly\n") + port))) + (chmod out #o555) + #t)))) + + (mlet %store-monad ((image (system-qemu-image/shared-store os)) + (initrd initrd) + (qemu (package->derivation qemu)) + (bash (package->derivation bash)) + (os (operating-system-derivation os)) + (builder builder)) + (derivation-expression "run-vm.sh" builder + #:inputs `(("qemu" ,qemu) + ("image" ,image) + ("bash" ,bash) + ("initrd" ,initrd) + ("os" ,os)))))) + ;;; vm.scm ends here -- cgit v1.3 From 53bd729e8cb834fd8d907c58dd54698f71298744 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 1 Feb 2014 01:58:37 +0100 Subject: gnu: Add preliminary Xorg service. * gnu/system/dmd.scm (xorg-service): New procedure. --- gnu/system/dmd.scm | 95 +++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 94 insertions(+), 1 deletion(-) (limited to 'gnu/system') diff --git a/gnu/system/dmd.scm b/gnu/system/dmd.scm index 2143b0042..505c4c9af 100644 --- a/gnu/system/dmd.scm +++ b/gnu/system/dmd.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Ludovic Courtès +;;; Copyright © 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,6 +29,10 @@ #:select (guix)) #:use-module ((gnu packages linux) #:select (net-tools)) + #:use-module (gnu packages xorg) + #:use-module (gnu packages bash) + #:use-module (gnu packages gl) + #:use-module (gnu system shadow) ; for user accounts/groups #:use-module (gnu system linux) ; for PAM services #:use-module (ice-9 match) @@ -54,6 +58,7 @@ nscd-service guix-service static-networking-service + xorg-service dmd-configuration-file)) @@ -265,6 +270,94 @@ true, it must be a string specifying the default network gateway." `(("net-tools" ,net-tools)) '()))))))) +(define (xorg-service) + "Return a service that starts the Xorg graphical display server." + (define (xserver.conf) + (mlet %store-monad ((fonts (package-file font-adobe75dpi + "lib/X11/fonts")) + (xorg (package-file xorg-server + "lib/xorg/modules")) + (vesa (package-file xf86-video-vesa + "lib/xorg/modules/drivers")) + (kbd (package-file xf86-input-keyboard + "lib/xorg/modules/input")) + (mouse (package-file xf86-input-mouse + "lib/xorg/modules/input"))) + (text-file "xserver.conf" ; let's go! + (string-append " +Section \"Files\" + FontPath \"" fonts "\" + ModulePath \"" vesa "\" + ModulePath \"" mouse "\" + ModulePath \"" kbd "\" + ModulePath \"" xorg "\" + ModulePath \"" xorg "/extensions\" + ModulePath \"" xorg "/multimedia\" +EndSection + +Section \"ServerFlags\" + Option \"AllowMouseOpenFail\" \"on"" +EndSection + +Section \"Monitor\" + Identifier \"Monitor[0]\" +EndSection + +Section \"InputClass\" + Identifier \"Generic keyboard\" + MatchIsKeyboard \"on\" + Option \"XkbRules\" \"base\" + Option \"XkbModel\" \"pc104\" +EndSection + +Section \"ServerLayout\" + Identifier \"Layout\" + Screen \"Screen-vesa\" +EndSection + +Section \"Device\" + Identifier \"Device-vesa\" + Driver \"vesa\" +EndSection + +Section \"Screen\" + Identifier \"Screen-vesa\" + Device \"Device-vesa\" +EndSection")))) + + (mlet %store-monad ((xorg-bin (package-file xorg-server "bin/X")) + (dri (package-file mesa "lib/dri")) + (xkbcomp-bin (package-file xkbcomp "bin")) + (xkb-dir (package-file xkeyboard-config + "share/X11/xkb")) + (sh (package-file bash "bin/sh")) + (config (xserver.conf))) + (return + (service + (documentation "The X11 graphic server") + (provision '(xorg-server)) + (requirement '(host-name)) + (start `(make-forkexec-constructor + ;; XXX: 'make-forkexec-constructor' should allow use to specify + ;; env vars. + ,sh "-c" ,(string-append "XORG_DRI_DRIVER_PATH=" dri " " + "XKB_BINDIR=" xkbcomp-bin " " + xorg-bin " -ac -logverbose -verbose " + "-xkbdir " xkb-dir " " + "-config " config " " + "-nolisten tcp :0 vt7"))) + (stop `(make-kill-destructor)) + (respawn? #f) + (inputs `(("xorg" ,xorg-server) + ("mesa" ,mesa) + ("xkbcomp" ,xkbcomp) + ("xkeyboard-config" ,xkeyboard-config) + ("vesa" ,xf86-video-vesa) + ("mouse" ,xf86-input-mouse) + ("kbd" ,xf86-input-keyboard) + ("fonts" ,font-adobe75dpi) + ("bash" ,bash))))))) + (define (dmd-configuration-file services etc) "Return the dmd configuration file for SERVICES, that initializes /etc from -- cgit v1.3 From f6a9d0484c6cdd1554f6ce0e7372ec8b7f2a52ca Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 2 Feb 2014 01:34:33 +0100 Subject: gnu: vm: Add /run/current-system and /bin/sh. * gnu/system/vm.scm (operating-system-default-contents): Populate /run/current-system and create /bin/sh. * gnu/system.scm (operating-system-profile-derivation, operating-system-profile-directory): New procedures. (operating-system-derivation): Use it. --- gnu/system.scm | 17 +++++++++++++---- gnu/system/vm.scm | 13 +++++++++---- 2 files changed, 22 insertions(+), 8 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system.scm b/gnu/system.scm index afea97616..514e67ab9 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -49,6 +49,7 @@ operating-system-locale operating-system-services + operating-system-profile-directory operating-system-derivation)) ;;; Commentary: @@ -284,6 +285,17 @@ alias ll='ls -l' ("pam.d" ,pam.d)) #:name "etc"))) +(define (operating-system-profile-derivation os) + "Return a derivation that builds the default profile of OS." + ;; TODO: Replace with a real profile with a manifest. + (union (operating-system-packages os) + #:name "default-profile")) + +(define (operating-system-profile-directory os) + "Return the directory name of the default profile of OS." + (mlet %store-monad ((drv (operating-system-profile-derivation os))) + (return (derivation->output-path drv)))) + (define (operating-system-derivation os) "Return a derivation that builds OS." (mlet* %store-monad @@ -310,11 +322,8 @@ alias ll='ls -l' services)))) (groups -> (append (operating-system-groups os) (append-map service-user-groups services))) - (packages -> (operating-system-packages os)) - ;; TODO: Replace with a real profile with a manifest. - (profile-drv (union packages - #:name "default-profile")) + (profile-drv (operating-system-profile-derivation os)) (profile -> (derivation->output-path profile-drv)) (etc-drv (etc-directory #:accounts accounts #:groups groups #:pam-services pam-services diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index f36cfd031..00edc8e40 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -458,15 +458,20 @@ such as /etc files." (define (operating-system-default-contents os) "Return a list of directives suitable for 'system-qemu-image' describing the basic contents of the root file system of OS." - (mlet* %store-monad ((os-drv (operating-system-derivation os)) - (os-dir -> (derivation->output-path os-drv)) - (build-user-gid (operating-system-build-gid os))) - (return `((directory "/nix/store" 0 ,(or build-user-gid 0)) + (mlet* %store-monad ((os-drv (operating-system-derivation os)) + (os-dir -> (derivation->output-path os-drv)) + (build-gid (operating-system-build-gid os)) + (profile (operating-system-profile-directory os))) + (return `((directory "/nix/store" 0 ,(or build-gid 0)) (directory "/etc") (directory "/var/log") ; for dmd (directory "/var/run/nscd") (directory "/var/nix/gcroots") ("/var/nix/gcroots/system" -> ,os-dir) + (directory "/run") + ("/run/current-system" -> ,profile) + (directory "/bin") + ("/bin/sh" -> "/run/current-system/bin/sh") (directory "/tmp") (directory "/var/nix/profiles/per-user/root" 0 0) (directory "/var/nix/profiles/per-user/guest" -- cgit v1.3 From 682b6599d775d0d6a594d84a38170bbd80fa6306 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 2 Feb 2014 20:41:53 +0100 Subject: gnu: vm: Create all the user directories. * gnu/system/vm.scm (operating-system-default-contents)[user-directories]: New procedure. Use it to create each user's home and GC root directories. --- gnu/system/vm.scm | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 00edc8e40..1bdd2c6e9 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -458,6 +458,16 @@ such as /etc files." (define (operating-system-default-contents os) "Return a list of directives suitable for 'system-qemu-image' describing the basic contents of the root file system of OS." + (define (user-directories user) + (let ((home (user-account-home-directory user)) + ;; XXX: Deal with automatically allocated ids. + (uid (or (user-account-uid user) 0)) + (gid (or (user-account-gid user) 0)) + (root (string-append "/var/nix/profiles/per-user/" + (user-account-name user)))) + `((directory ,root ,uid ,gid) + (directory ,home ,uid ,gid)))) + (mlet* %store-monad ((os-drv (operating-system-derivation os)) (os-dir -> (derivation->output-path os-drv)) (build-gid (operating-system-build-gid os)) @@ -471,12 +481,12 @@ basic contents of the root file system of OS." (directory "/run") ("/run/current-system" -> ,profile) (directory "/bin") - ("/bin/sh" -> "/run/current-system/bin/sh") + ("/bin/sh" -> "/run/current-system/bin/bash") (directory "/tmp") (directory "/var/nix/profiles/per-user/root" 0 0) - (directory "/var/nix/profiles/per-user/guest" - 1000 100) - (directory "/home/guest" 1000 100))))) + + ,@(append-map user-directories + (operating-system-users os)))))) (define* (system-qemu-image #:optional (os %demo-operating-system) #:key (disk-image-size (* 900 (expt 2 20)))) -- cgit v1.3 From 7c9325a9ecad1a8d02793aadb2e1730b4a8de48b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 3 Feb 2014 23:37:09 +0100 Subject: gnu: dmd: Use 'text-file*' when building Xorg's config file. * gnu/system/dmd.scm (xorg-service)[xserver.conf]: Change to use 'text-file*' instead of 'text-file'. Adjust body accordingly. Remove now extraneous packages from the service's 'inputs' field. --- gnu/system/dmd.scm | 41 ++++++++++++++--------------------------- 1 file changed, 14 insertions(+), 27 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/dmd.scm b/gnu/system/dmd.scm index 505c4c9af..656c2f563 100644 --- a/gnu/system/dmd.scm +++ b/gnu/system/dmd.scm @@ -273,26 +273,15 @@ true, it must be a string specifying the default network gateway." (define (xorg-service) "Return a service that starts the Xorg graphical display server." (define (xserver.conf) - (mlet %store-monad ((fonts (package-file font-adobe75dpi - "lib/X11/fonts")) - (xorg (package-file xorg-server - "lib/xorg/modules")) - (vesa (package-file xf86-video-vesa - "lib/xorg/modules/drivers")) - (kbd (package-file xf86-input-keyboard - "lib/xorg/modules/input")) - (mouse (package-file xf86-input-mouse - "lib/xorg/modules/input"))) - (text-file "xserver.conf" ; let's go! - (string-append " + (text-file* "xserver.conf" " Section \"Files\" - FontPath \"" fonts "\" - ModulePath \"" vesa "\" - ModulePath \"" mouse "\" - ModulePath \"" kbd "\" - ModulePath \"" xorg "\" - ModulePath \"" xorg "/extensions\" - ModulePath \"" xorg "/multimedia\" + FontPath \"" font-adobe75dpi "/lib/X11/fonts\" + ModulePath \"" xf86-video-vesa "/lib/xorg/modules/drivers\" + ModulePath \"" xf86-input-mouse "/lib/xorg/modules/input\" + ModulePath \"" xf86-input-keyboard "/lib/xorg/modules/input\" + ModulePath \"" xorg-server "/lib/xorg/modules\" + ModulePath \"" xorg-server "/lib/xorg/modules/extensions\" + ModulePath \"" xorg-server "/lib/xorg/modules/multimedia\" EndSection Section \"ServerFlags\" @@ -323,7 +312,7 @@ EndSection Section \"Screen\" Identifier \"Screen-vesa\" Device \"Device-vesa\" -EndSection")))) +EndSection")) (mlet %store-monad ((xorg-bin (package-file xorg-server "bin/X")) (dri (package-file mesa "lib/dri")) @@ -344,19 +333,17 @@ EndSection")))) "XKB_BINDIR=" xkbcomp-bin " " xorg-bin " -ac -logverbose -verbose " "-xkbdir " xkb-dir " " - "-config " config " " + "-config " + (derivation->output-path config) " " "-nolisten tcp :0 vt7"))) (stop `(make-kill-destructor)) (respawn? #f) (inputs `(("xorg" ,xorg-server) - ("mesa" ,mesa) ("xkbcomp" ,xkbcomp) ("xkeyboard-config" ,xkeyboard-config) - ("vesa" ,xf86-video-vesa) - ("mouse" ,xf86-input-mouse) - ("kbd" ,xf86-input-keyboard) - ("fonts" ,font-adobe75dpi) - ("bash" ,bash))))))) + ("mesa" ,mesa) + ("bash" ,bash) + ("xorg.conf" ,config))))))) (define (dmd-configuration-file services etc) -- cgit v1.3 From ea0e9ce2e6d0c99106c47ee32203b92933a837de Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 8 Feb 2014 00:18:25 +0100 Subject: gnu: Move root's home directory to /root. * gnu/system.scm (operating-system-derivation): Change root's 'home-directory' to "/root". * gnu/system/vm.scm (operating-system-default-contents): Add /root. --- gnu/system.scm | 2 +- gnu/system/vm.scm | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) (limited to 'gnu/system') diff --git a/gnu/system.scm b/gnu/system.scm index e06b8103a..6918d5bcb 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -317,7 +317,7 @@ alias ll='ls -l' (password "") (uid 0) (gid 0) (comment "System administrator") - (home-directory "/")) + (home-directory "/root")) (append (operating-system-users os) (append-map service-user-accounts services)))) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 1bdd2c6e9..dea7d0599 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -485,6 +485,7 @@ basic contents of the root file system of OS." (directory "/tmp") (directory "/var/nix/profiles/per-user/root" 0 0) + (directory "/root" 0 0) ; an exception ,@(append-map user-directories (operating-system-users os)))))) -- cgit v1.3 From f3d4af173a09b29454155def7d8058b21b83d27b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 9 Feb 2014 23:30:49 +0100 Subject: gnu: dmd: Fix X font directory name in X service. * gnu/system/dmd.scm (xorg-service)[xserver.conf]: Fix directory name in 'FontPath' entry for FONT-ADOBE75DPI. --- gnu/system/dmd.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gnu/system') diff --git a/gnu/system/dmd.scm b/gnu/system/dmd.scm index 656c2f563..8fe225f0e 100644 --- a/gnu/system/dmd.scm +++ b/gnu/system/dmd.scm @@ -275,7 +275,7 @@ true, it must be a string specifying the default network gateway." (define (xserver.conf) (text-file* "xserver.conf" " Section \"Files\" - FontPath \"" font-adobe75dpi "/lib/X11/fonts\" + FontPath \"" font-adobe75dpi "/share/font/X11/75dpi\" ModulePath \"" xf86-video-vesa "/lib/xorg/modules/drivers\" ModulePath \"" xf86-input-mouse "/lib/xorg/modules/input\" ModulePath \"" xf86-input-keyboard "/lib/xorg/modules/input\" -- cgit v1.3 From 06d275f67f9ad58ea041f3e31add95fe48631f50 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 9 Feb 2014 23:46:28 +0100 Subject: gnu: dmd: Add SLiM service. * gnu/system/dmd.scm (xorg-service): Remove. (xorg-start-command, slim-service): New procedure. --- gnu/system/dmd.scm | 124 ++++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 99 insertions(+), 25 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/dmd.scm b/gnu/system/dmd.scm index 8fe225f0e..c1ddec88d 100644 --- a/gnu/system/dmd.scm +++ b/gnu/system/dmd.scm @@ -22,9 +22,9 @@ #:use-module (guix derivations) #:use-module (guix records) #:use-module ((gnu packages base) - #:select (glibc-final)) + #:select (glibc-final guile-final)) #:use-module ((gnu packages admin) - #:select (mingetty inetutils shadow)) + #:select (dmd mingetty inetutils shadow)) #:use-module ((gnu packages package-management) #:select (guix)) #:use-module ((gnu packages linux) @@ -32,6 +32,8 @@ #:use-module (gnu packages xorg) #:use-module (gnu packages bash) #:use-module (gnu packages gl) + #:use-module (gnu packages slim) + #:use-module (gnu packages ratpoison) #:use-module (gnu system shadow) ; for user accounts/groups #:use-module (gnu system linux) ; for PAM services @@ -58,7 +60,8 @@ nscd-service guix-service static-networking-service - xorg-service + xorg-start-command + slim-service dmd-configuration-file)) @@ -270,8 +273,12 @@ true, it must be a string specifying the default network gateway." `(("net-tools" ,net-tools)) '()))))))) -(define (xorg-service) - "Return a service that starts the Xorg graphical display server." +(define* (xorg-start-command #:key + (guile guile-final) + (xorg-server xorg-server)) + "Return a derivation that builds a GUILE script to start the X server from +XORG-SERVER. Usually the X server is started by a login manager." + (define (xserver.conf) (text-file* "xserver.conf" " Section \"Files\" @@ -314,36 +321,103 @@ Section \"Screen\" Device \"Device-vesa\" EndSection")) - (mlet %store-monad ((xorg-bin (package-file xorg-server "bin/X")) + (mlet %store-monad ((guile-bin (package-file guile "bin/guile")) + (xorg-bin (package-file xorg-server "bin/X")) (dri (package-file mesa "lib/dri")) (xkbcomp-bin (package-file xkbcomp "bin")) (xkb-dir (package-file xkeyboard-config "share/X11/xkb")) - (sh (package-file bash "bin/sh")) (config (xserver.conf))) + (define builder + ;; Write a small wrapper around the X server. + `(let ((out (assoc-ref %outputs "out"))) + (call-with-output-file out + (lambda (port) + (format port "#!~a --no-auto-compile~%!#~%" ,guile-bin) + (write '(begin + (setenv "XORG_DRI_DRIVER_PATH" ,dri) + (setenv "XKB_BINDIR" ,xkbcomp-bin) + + (apply execl + + ,xorg-bin "-ac" "-logverbose" "-verbose" + "-xkbdir" ,xkb-dir + "-config" ,(derivation->output-path config) + "-nolisten" "tcp" "-terminate" + + ;; Note: SLiM and other display managers add the + ;; '-auth' flag by themselves. + (cdr (command-line)))) + port))) + (chmod out #o555) + #t)) + + (mlet %store-monad ((inputs (lower-inputs + `(("xorg" ,xorg-server) + ("xkbcomp" ,xkbcomp) + ("xkeyboard-config" ,xkeyboard-config) + ("mesa" ,mesa) + ("guile" ,guile) + ("xorg.conf" ,config))))) + (derivation-expression "start-xorg" builder + #:inputs inputs)))) + +(define* (slim-service #:key (slim slim) + (allow-empty-passwords? #t) auto-login? + (default-user "") + (xauth xauth) (dmd dmd) (bash bash) + startx) + "Return a service that spawns the SLiM graphical login manager, which in +turn start the X display server with STARTX, a command as returned by +'xorg-start-command'. + +When ALLOW-EMPTY-PASSWORDS? is true, allow logins with an empty password. +When AUTO-LOGIN? is true, log in automatically as DEFAULT-USER." + (define (slim.cfg) + ;; TODO: Run "bash -login ~/.xinitrc %session". + (mlet %store-monad ((startx (or startx (xorg-start-command)))) + (text-file* "slim.cfg" " +default_path /run/current-system/bin +default_xserver " startx " +xserver_arguments :0 vt7 +xauth_path " xauth "/bin/xauth +authfile /var/run/slim.auth + +# The login command. '%session' is replaced by the chosen session name, one +# of the names specified in the 'sessions' setting: 'wmaker', 'xfce', etc. +login_cmd exec " ratpoison "/bin/ratpoison + +halt_cmd " dmd "/sbin/halt +reboot_cmd " dmd "/sbin/reboot +" (if auto-login? + (string-append "auto_login yes\ndefault_user " default-user) + "")))) + + (mlet %store-monad ((slim-bin (package-file slim "bin/slim")) + (bash-bin (package-file bash "bin/bash")) + (slim.cfg (slim.cfg))) (return (service - (documentation "The X11 graphic server") + (documentation "Xorg display server") (provision '(xorg-server)) (requirement '(host-name)) - (start `(make-forkexec-constructor - ;; XXX: 'make-forkexec-constructor' should allow use to specify - ;; env vars. - ,sh "-c" ,(string-append "XORG_DRI_DRIVER_PATH=" dri " " - "XKB_BINDIR=" xkbcomp-bin " " - xorg-bin " -ac -logverbose -verbose " - "-xkbdir " xkb-dir " " - "-config " - (derivation->output-path config) " " - "-nolisten tcp :0 vt7"))) + (start + ;; XXX: Work around the inability to specify env. vars. directly. + `(make-forkexec-constructor + ,bash-bin "-c" + ,(string-append "SLIM_CFGFILE=" (derivation->output-path slim.cfg) + " " slim-bin + " -nodaemon"))) (stop `(make-kill-destructor)) - (respawn? #f) - (inputs `(("xorg" ,xorg-server) - ("xkbcomp" ,xkbcomp) - ("xkeyboard-config" ,xkeyboard-config) - ("mesa" ,mesa) - ("bash" ,bash) - ("xorg.conf" ,config))))))) + (inputs `(("slim" ,slim) + ("slim.cfg" ,slim.cfg) + ("bash" ,bash))) + (respawn? #t) + (pam-services + ;; Tell PAM about 'slim'. + (list (unix-pam-service + "slim" + #:allow-empty-passwords? allow-empty-passwords?))))))) (define (dmd-configuration-file services etc) -- cgit v1.3 From db4fdc04cc05495788ee54ae25baf8cd056917dc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 19 Feb 2014 20:58:24 +0100 Subject: gnu: Introduce the (gnu services ...) modules. * gnu/system/dmd.scm: Remove file. Move contents to... * gnu/services.scm, gnu/services/base.scm, gnu/services/dmd.scm, gnu/services/networking.scm, gnu/services/xorg.scm: ... here. New files. * gnu/system.scm, gnu/system/vm.scm: Adjust accordingly. * guix/scripts/system.scm (%user-module): Likewise. * doc/guix.texi (Using the Configuration System): Likewise. (Defining Services): Likewise. --- doc/guix.texi | 8 +- gnu-system.am | 11 +- gnu/services.scm | 62 ++++++ gnu/services/base.scm | 176 +++++++++++++++++ gnu/services/dmd.scm | 77 ++++++++ gnu/services/networking.scm | 80 ++++++++ gnu/services/xorg.scm | 186 ++++++++++++++++++ gnu/system.scm | 6 +- gnu/system/dmd.scm | 470 -------------------------------------------- gnu/system/vm.scm | 2 +- guix/scripts/system.scm | 2 +- 11 files changed, 600 insertions(+), 480 deletions(-) create mode 100644 gnu/services.scm create mode 100644 gnu/services/base.scm create mode 100644 gnu/services/dmd.scm create mode 100644 gnu/services/networking.scm create mode 100644 gnu/services/xorg.scm delete mode 100644 gnu/system/dmd.scm (limited to 'gnu/system') diff --git a/doc/guix.texi b/doc/guix.texi index e6636dc71..9a0deeac5 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2562,9 +2562,9 @@ Linux-Libre kernel, initial RAM disk, and boot loader looks like this: @findex operating-system @lisp -(use-modules (gnu system) +(use-modules (gnu services base) + (gnu services ssh) ; for 'lsh-service' (gnu system shadow) ; for 'user-account' - (gnu system service) ; for 'lsh-service' (gnu packages base) ; Coreutils, grep, etc. (gnu packages bash) ; Bash (gnu packages admin) ; dmd, Inetutils @@ -2603,7 +2603,7 @@ visible on the system, for all user accounts---i.e., in every user's The @code{services} field lists @dfn{system services} to be made available when the system starts. The @var{%standard-services} list, -from the @code{(gnu system)} module, provides the basic services one +from the @code{(gnu services base)} module, provides the basic services one would expect from a GNU system: a login service (mingetty) on each tty, syslogd, libc's name service cache daemon (nscd), etc. @@ -2666,7 +2666,7 @@ The VM shares its store with the host system. @node Defining Services @subsection Defining Services -The @code{(gnu system dmd)} module defines several procedures that allow +The @code{(gnu services @dots{})} modules define several procedures that allow users to declare the operating system's services (@pxref{Using the Configuration System}). These procedures are @emph{monadic procedures}---i.e., procedures that return a monadic value in the store diff --git a/gnu-system.am b/gnu-system.am index d231cfa57..857c9bf66 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -70,7 +70,7 @@ GNU_SYSTEM_MODULES = \ gnu/packages/fonts.scm \ gnu/packages/fontutils.scm \ gnu/packages/freeipmi.scm \ - gnu/packages/games.scm \ + gnu/packages/games.scm \ gnu/packages/gawk.scm \ gnu/packages/gcal.scm \ gnu/packages/gcc.scm \ @@ -210,7 +210,7 @@ GNU_SYSTEM_MODULES = \ gnu/packages/vpn.scm \ gnu/packages/w3m.scm \ gnu/packages/wdiff.scm \ - gnu/packages/web.scm \ + gnu/packages/web.scm \ gnu/packages/wget.scm \ gnu/packages/which.scm \ gnu/packages/wordnet.scm \ @@ -223,8 +223,13 @@ GNU_SYSTEM_MODULES = \ gnu/packages/zile.scm \ gnu/packages/zip.scm \ \ + gnu/services.scm \ + gnu/services/base.scm \ + gnu/services/dmd.scm \ + gnu/services/networking.scm \ + gnu/services/xorg.scm \ + \ gnu/system.scm \ - gnu/system/dmd.scm \ gnu/system/grub.scm \ gnu/system/linux.scm \ gnu/system/linux-initrd.scm \ diff --git a/gnu/services.scm b/gnu/services.scm new file mode 100644 index 000000000..eccde4e9a --- /dev/null +++ b/gnu/services.scm @@ -0,0 +1,62 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu services) + #:use-module (guix records) + #:export (service? + service + service-documentation + service-provision + service-requirement + service-respawn? + service-start + service-stop + service-inputs + service-user-accounts + service-user-groups + service-pam-services)) + +;;; Commentary: +;;; +;;; System services as cajoled by dmd. +;;; +;;; Code: + +(define-record-type* + service make-service + service? + (documentation service-documentation ; string + (default "[No documentation.]")) + (provision service-provision) ; list of symbols + (requirement service-requirement ; list of symbols + (default '())) + (respawn? service-respawn? ; Boolean + (default #t)) + (start service-start) ; expression + (stop service-stop ; expression + (default #f)) + (inputs service-inputs ; list of inputs + (default '())) + (user-accounts service-user-accounts ; list of + (default '())) + (user-groups service-user-groups ; list of + (default '())) + (pam-services service-pam-services ; list of + (default '()))) + +;;; services.scm ends here. diff --git a/gnu/services/base.scm b/gnu/services/base.scm new file mode 100644 index 000000000..3d684a5be --- /dev/null +++ b/gnu/services/base.scm @@ -0,0 +1,176 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu services base) + #:use-module (gnu services) + #:use-module (gnu system shadow) ; 'user-account', etc. + #:use-module (gnu system linux) ; 'pam-service', etc. + #:use-module (gnu packages admin) + #:use-module ((gnu packages base) + #:select (glibc-final)) + #:use-module (gnu packages package-management) + #:use-module (guix monads) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (ice-9 format) + #:export (host-name-service + mingetty-service + nscd-service + syslog-service + guix-service)) + +;;; Commentary: +;;; +;;; Base system services---i.e., services that 99% of the users will want to +;;; use. +;;; +;;; Code: + +(define (host-name-service name) + "Return a service that sets the host name to NAME." + (with-monad %store-monad + (return (service + (documentation "Initialize the machine's host name.") + (provision '(host-name)) + (start `(lambda _ + (sethostname ,name))) + (respawn? #f))))) + +(define* (mingetty-service tty + #:key + (motd (text-file "motd" "Welcome.\n")) + (allow-empty-passwords? #t)) + "Return a service to run mingetty on TTY." + (mlet %store-monad ((mingetty-bin (package-file mingetty "sbin/mingetty")) + (motd motd)) + (return + (service + (documentation (string-append "Run mingetty on " tty ".")) + (provision (list (symbol-append 'term- (string->symbol tty)))) + + ;; Since the login prompt shows the host name, wait for the 'host-name' + ;; service to be done. + (requirement '(host-name)) + + (start `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty)) + (stop `(make-kill-destructor)) + (inputs `(("mingetty" ,mingetty) + ("motd" ,motd))) + + (pam-services + ;; Let 'login' be known to PAM. All the mingetty services will have + ;; that PAM service, but that's fine because they're all identical and + ;; duplicates are removed. + (list (unix-pam-service "login" + #:allow-empty-passwords? allow-empty-passwords? + #:motd motd))))))) + +(define* (nscd-service #:key (glibc glibc-final)) + "Return a service that runs libc's name service cache daemon (nscd)." + (mlet %store-monad ((nscd (package-file glibc "sbin/nscd"))) + (return (service + (documentation "Run libc's name service cache daemon (nscd).") + (provision '(nscd)) + (start `(make-forkexec-constructor ,nscd "-f" "/dev/null" + "--foreground")) + (stop `(make-kill-destructor)) + + (respawn? #f) + (inputs `(("glibc" ,glibc))))))) + +(define (syslog-service) + "Return a service that runs 'syslogd' with reasonable default settings." + + ;; Snippet adapted from the GNU inetutils manual. + (define contents " + # Log all kernel messages, authentication messages of + # level notice or higher and anything of level err or + # higher to the console. + # Don't log private authentication messages! + *.err;kern.*;auth.notice;authpriv.none /dev/console + + # Log anything (except mail) of level info or higher. + # Don't log private authentication messages! + *.info;mail.none;authpriv.none /var/log/messages + + # Same, in a different place. + *.info;mail.none;authpriv.none /dev/tty12 + + # The authpriv file has restricted access. + authpriv.* /var/log/secure + + # Log all the mail messages in one place. + mail.* /var/log/maillog +") + + (mlet %store-monad + ((syslog.conf (text-file "syslog.conf" contents)) + (syslogd (package-file inetutils "libexec/syslogd"))) + (return + (service + (documentation "Run the syslog daemon (syslogd).") + (provision '(syslogd)) + (start `(make-forkexec-constructor ,syslogd "--no-detach" + "--rcfile" ,syslog.conf)) + (stop `(make-kill-destructor)) + (inputs `(("inetutils" ,inetutils) + ("syslog.conf" ,syslog.conf))))))) + +(define* (guix-build-accounts count #:key + (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." + (with-monad %store-monad + (return (unfold (cut > <> count) + (lambda (n) + (user-account + (name (format #f "guixbuilder~2,'0d" n)) + (password "!") + (uid (+ first-uid n -1)) + (gid gid) + (comment (format #f "Guix Build User ~2d" n)) + (home-directory "/var/empty") + (shell (package-file shadow "sbin/nologin")) + (inputs `(("shadow" ,shadow))))) + 1+ + 1)))) + +(define* (guix-service #:key (guix guix) (builder-group "guixbuild") + (build-user-gid 30000) (build-accounts 10)) + "Return a service that runs the build daemon from GUIX, and has +BUILD-ACCOUNTS user accounts available under BUILD-USER-GID." + (mlet %store-monad ((daemon (package-file guix "bin/guix-daemon")) + (accounts (guix-build-accounts build-accounts + #:gid build-user-gid))) + (return (service + (provision '(guix-daemon)) + (start `(make-forkexec-constructor ,daemon + "--build-users-group" + ,builder-group)) + (stop `(make-kill-destructor)) + (inputs `(("guix" ,guix))) + (user-accounts accounts) + (user-groups (list (user-group + (name builder-group) + (id build-user-gid) + (members (map user-account-name + user-accounts))))))))) + +;;; base.scm ends here diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm new file mode 100644 index 000000000..21719118e --- /dev/null +++ b/gnu/services/dmd.scm @@ -0,0 +1,77 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu services dmd) + #:use-module (guix monads) + #:use-module (gnu services) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:export (dmd-configuration-file)) + +;;; Commentary: +;;; +;;; Instantiating system services as a dmd configuration file. +;;; +;;; Code: + +(define (dmd-configuration-file services etc) + "Return the dmd configuration file for SERVICES, that initializes /etc from +ETC (the name of a directory in the store) on startup." + (define config + `(begin + (use-modules (ice-9 ftw)) + + (register-services + ,@(map (lambda (service) + `(make + #:docstring ',(service-documentation service) + #:provides ',(service-provision service) + #:requires ',(service-requirement service) + #:respawn? ',(service-respawn? service) + #:start ,(service-start service) + #:stop ,(service-stop service))) + services)) + + ;; /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/nix/gcroots/etc-directory") + (symlink ,etc "/var/nix/gcroots/etc-directory")) + + (format #t "starting services...~%") + (for-each start ',(append-map service-provision services)))) + + (text-file "dmd.conf" (object->string config))) + +;;; dmd.scm ends here diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm new file mode 100644 index 000000000..317800db5 --- /dev/null +++ b/gnu/services/networking.scm @@ -0,0 +1,80 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu services networking) + #:use-module (gnu services) + #:use-module (gnu packages admin) + #:use-module (gnu packages linux) + #:use-module (guix monads) + #:export (static-networking-service)) + +;;; Commentary: +;;; +;;; Networking services. +;;; +;;; Code: + +(define* (static-networking-service interface ip + #:key + gateway + (name-servers '()) + (inetutils inetutils) + (net-tools net-tools)) + "Return a service that starts INTERFACE with address IP. If GATEWAY is +true, it must be a string specifying the default network gateway." + + ;; TODO: Eventually we should do this using Guile's networking procedures, + ;; like 'configure-qemu-networking' does, but the patch that does this is + ;; not yet in stock Guile. + (mlet %store-monad ((ifconfig (package-file inetutils "bin/ifconfig")) + (route (package-file net-tools "sbin/route"))) + (return + (service + (documentation + (string-append "Set up networking on the '" interface + "' interface using a static IP address.")) + (provision '(networking)) + (start `(lambda _ + ;; Return #t if successfully started. + (and (zero? (system* ,ifconfig ,interface ,ip "up")) + ,(if gateway + `(zero? (system* ,route "add" "-net" "default" + "gw" ,gateway)) + #t) + ,(if (pair? name-servers) + `(call-with-output-file "/etc/resolv.conf" + (lambda (port) + (display + "# Generated by 'static-networking-service'.\n" + port) + (for-each (lambda (server) + (format port "nameserver ~a~%" + server)) + ',name-servers))) + #t)))) + (stop `(lambda _ + ;; Return #f is successfully stopped. + (not (and (system* ,ifconfig ,interface "down") + (system* ,route "del" "-net" "default"))))) + (respawn? #f) + (inputs `(("inetutils" ,inetutils) + ,@(if gateway + `(("net-tools" ,net-tools)) + '()))))))) + +;;; networking.scm ends here diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm new file mode 100644 index 000000000..702be2771 --- /dev/null +++ b/gnu/services/xorg.scm @@ -0,0 +1,186 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu services xorg) + #:use-module (gnu services) + #:use-module (gnu system linux) ; 'pam-service' + #:use-module ((gnu packages base) #:select (guile-final)) + #:use-module (gnu packages xorg) + #:use-module (gnu packages gl) + #:use-module (gnu packages slim) + #:use-module (gnu packages ratpoison) + #:use-module (gnu packages admin) + #:use-module (gnu packages bash) + #:use-module (guix monads) + #:use-module (guix derivations) + #:export (xorg-start-command + slim-service)) + +;;; Commentary: +;;; +;;; Services that relate to the X Window System. +;;; +;;; Code: + +(define* (xorg-start-command #:key + (guile guile-final) + (xorg-server xorg-server)) + "Return a derivation that builds a GUILE script to start the X server from +XORG-SERVER. Usually the X server is started by a login manager." + + (define (xserver.conf) + (text-file* "xserver.conf" " +Section \"Files\" + FontPath \"" font-adobe75dpi "/share/font/X11/75dpi\" + ModulePath \"" xf86-video-vesa "/lib/xorg/modules/drivers\" + ModulePath \"" xf86-input-mouse "/lib/xorg/modules/input\" + ModulePath \"" xf86-input-keyboard "/lib/xorg/modules/input\" + ModulePath \"" xorg-server "/lib/xorg/modules\" + ModulePath \"" xorg-server "/lib/xorg/modules/extensions\" + ModulePath \"" xorg-server "/lib/xorg/modules/multimedia\" +EndSection + +Section \"ServerFlags\" + Option \"AllowMouseOpenFail\" \"on"" +EndSection + +Section \"Monitor\" + Identifier \"Monitor[0]\" +EndSection + +Section \"InputClass\" + Identifier \"Generic keyboard\" + MatchIsKeyboard \"on\" + Option \"XkbRules\" \"base\" + Option \"XkbModel\" \"pc104\" +EndSection + +Section \"ServerLayout\" + Identifier \"Layout\" + Screen \"Screen-vesa\" +EndSection + +Section \"Device\" + Identifier \"Device-vesa\" + Driver \"vesa\" +EndSection + +Section \"Screen\" + Identifier \"Screen-vesa\" + Device \"Device-vesa\" +EndSection")) + + (mlet %store-monad ((guile-bin (package-file guile "bin/guile")) + (xorg-bin (package-file xorg-server "bin/X")) + (dri (package-file mesa "lib/dri")) + (xkbcomp-bin (package-file xkbcomp "bin")) + (xkb-dir (package-file xkeyboard-config + "share/X11/xkb")) + (config (xserver.conf))) + (define builder + ;; Write a small wrapper around the X server. + `(let ((out (assoc-ref %outputs "out"))) + (call-with-output-file out + (lambda (port) + (format port "#!~a --no-auto-compile~%!#~%" ,guile-bin) + (write '(begin + (setenv "XORG_DRI_DRIVER_PATH" ,dri) + (setenv "XKB_BINDIR" ,xkbcomp-bin) + + (apply execl + + ,xorg-bin "-ac" "-logverbose" "-verbose" + "-xkbdir" ,xkb-dir + "-config" ,(derivation->output-path config) + "-nolisten" "tcp" "-terminate" + + ;; Note: SLiM and other display managers add the + ;; '-auth' flag by themselves. + (cdr (command-line)))) + port))) + (chmod out #o555) + #t)) + + (mlet %store-monad ((inputs (lower-inputs + `(("xorg" ,xorg-server) + ("xkbcomp" ,xkbcomp) + ("xkeyboard-config" ,xkeyboard-config) + ("mesa" ,mesa) + ("guile" ,guile) + ("xorg.conf" ,config))))) + (derivation-expression "start-xorg" builder + #:inputs inputs)))) + +(define* (slim-service #:key (slim slim) + (allow-empty-passwords? #t) auto-login? + (default-user "") + (xauth xauth) (dmd dmd) (bash bash) + startx) + "Return a service that spawns the SLiM graphical login manager, which in +turn start the X display server with STARTX, a command as returned by +'xorg-start-command'. + +When ALLOW-EMPTY-PASSWORDS? is true, allow logins with an empty password. +When AUTO-LOGIN? is true, log in automatically as DEFAULT-USER." + (define (slim.cfg) + ;; TODO: Run "bash -login ~/.xinitrc %session". + (mlet %store-monad ((startx (or startx (xorg-start-command)))) + (text-file* "slim.cfg" " +default_path /run/current-system/bin +default_xserver " startx " +xserver_arguments :0 vt7 +xauth_path " xauth "/bin/xauth +authfile /var/run/slim.auth + +# The login command. '%session' is replaced by the chosen session name, one +# of the names specified in the 'sessions' setting: 'wmaker', 'xfce', etc. +login_cmd exec " ratpoison "/bin/ratpoison + +halt_cmd " dmd "/sbin/halt +reboot_cmd " dmd "/sbin/reboot +" (if auto-login? + (string-append "auto_login yes\ndefault_user " default-user) + "")))) + + (mlet %store-monad ((slim-bin (package-file slim "bin/slim")) + (bash-bin (package-file bash "bin/bash")) + (slim.cfg (slim.cfg))) + (return + (service + (documentation "Xorg display server") + (provision '(xorg-server)) + (requirement '(host-name)) + (start + ;; XXX: Work around the inability to specify env. vars. directly. + `(make-forkexec-constructor + ,bash-bin "-c" + ,(string-append "SLIM_CFGFILE=" (derivation->output-path slim.cfg) + " " slim-bin + " -nodaemon"))) + (stop `(make-kill-destructor)) + (inputs `(("slim" ,slim) + ("slim.cfg" ,slim.cfg) + ("bash" ,bash))) + (respawn? #t) + (pam-services + ;; Tell PAM about 'slim'. + (list (unix-pam-service + "slim" + #:allow-empty-passwords? allow-empty-passwords?))))))) + +;;; xorg.scm ends here diff --git a/gnu/system.scm b/gnu/system.scm index 6918d5bcb..f05b7a092 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -26,7 +26,11 @@ #:use-module (gnu packages bash) #:use-module (gnu packages admin) #:use-module (gnu packages package-management) - #:use-module (gnu system dmd) + #:use-module (gnu services) + #:use-module (gnu services dmd) + #:use-module (gnu services base) + #:use-module ((gnu services networking) + #:select (static-networking-service)) #:use-module (gnu system grub) #:use-module (gnu system shadow) #:use-module (gnu system linux) diff --git a/gnu/system/dmd.scm b/gnu/system/dmd.scm deleted file mode 100644 index c1ddec88d..000000000 --- a/gnu/system/dmd.scm +++ /dev/null @@ -1,470 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014 Ludovic Courtès -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (gnu system dmd) - #:use-module (guix store) - #:use-module (guix packages) - #:use-module (guix derivations) - #:use-module (guix records) - #:use-module ((gnu packages base) - #:select (glibc-final guile-final)) - #:use-module ((gnu packages admin) - #:select (dmd mingetty inetutils shadow)) - #:use-module ((gnu packages package-management) - #:select (guix)) - #:use-module ((gnu packages linux) - #:select (net-tools)) - #:use-module (gnu packages xorg) - #:use-module (gnu packages bash) - #:use-module (gnu packages gl) - #:use-module (gnu packages slim) - #:use-module (gnu packages ratpoison) - - #:use-module (gnu system shadow) ; for user accounts/groups - #:use-module (gnu system linux) ; for PAM services - #:use-module (ice-9 match) - #:use-module (ice-9 format) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) - #:use-module (guix monads) - #:export (service? - service - service-provision - service-requirement - service-respawn? - service-start - service-stop - service-inputs - service-user-accounts - service-user-groups - service-pam-services - - host-name-service - syslog-service - mingetty-service - nscd-service - guix-service - static-networking-service - xorg-start-command - slim-service - - dmd-configuration-file)) - -;;; Commentary: -;;; -;;; System services as cajoled by dmd. -;;; -;;; Code: - -(define-record-type* - service make-service - service? - (documentation service-documentation ; string - (default "[No documentation.]")) - (provision service-provision) ; list of symbols - (requirement service-requirement ; list of symbols - (default '())) - (respawn? service-respawn? ; Boolean - (default #t)) - (start service-start) ; expression - (stop service-stop ; expression - (default #f)) - (inputs service-inputs ; list of inputs - (default '())) - (user-accounts service-user-accounts ; list of - (default '())) - (user-groups service-user-groups ; list of - (default '())) - (pam-services service-pam-services ; list of - (default '()))) - -(define (host-name-service name) - "Return a service that sets the host name to NAME." - (with-monad %store-monad - (return (service - (documentation "Initialize the machine's host name.") - (provision '(host-name)) - (start `(lambda _ - (sethostname ,name))) - (respawn? #f))))) - -(define* (mingetty-service tty - #:key - (motd (text-file "motd" "Welcome.\n")) - (allow-empty-passwords? #t)) - "Return a service to run mingetty on TTY." - (mlet %store-monad ((mingetty-bin (package-file mingetty "sbin/mingetty")) - (motd motd)) - (return - (service - (documentation (string-append "Run mingetty on " tty ".")) - (provision (list (symbol-append 'term- (string->symbol tty)))) - - ;; Since the login prompt shows the host name, wait for the 'host-name' - ;; service to be done. - (requirement '(host-name)) - - (start `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty)) - (stop `(make-kill-destructor)) - (inputs `(("mingetty" ,mingetty) - ("motd" ,motd))) - - (pam-services - ;; Let 'login' be known to PAM. All the mingetty services will have - ;; that PAM service, but that's fine because they're all identical and - ;; duplicates are removed. - (list (unix-pam-service "login" - #:allow-empty-passwords? allow-empty-passwords? - #:motd motd))))))) - -(define* (nscd-service #:key (glibc glibc-final)) - "Return a service that runs libc's name service cache daemon (nscd)." - (mlet %store-monad ((nscd (package-file glibc "sbin/nscd"))) - (return (service - (documentation "Run libc's name service cache daemon (nscd).") - (provision '(nscd)) - (start `(make-forkexec-constructor ,nscd "-f" "/dev/null" - "--foreground")) - (stop `(make-kill-destructor)) - - (respawn? #f) - (inputs `(("glibc" ,glibc))))))) - -(define (syslog-service) - "Return a service that runs 'syslogd' with reasonable default settings." - - ;; Snippet adapted from the GNU inetutils manual. - (define contents " - # Log all kernel messages, authentication messages of - # level notice or higher and anything of level err or - # higher to the console. - # Don't log private authentication messages! - *.err;kern.*;auth.notice;authpriv.none /dev/console - - # Log anything (except mail) of level info or higher. - # Don't log private authentication messages! - *.info;mail.none;authpriv.none /var/log/messages - - # Same, in a different place. - *.info;mail.none;authpriv.none /dev/tty12 - - # The authpriv file has restricted access. - authpriv.* /var/log/secure - - # Log all the mail messages in one place. - mail.* /var/log/maillog -") - - (mlet %store-monad - ((syslog.conf (text-file "syslog.conf" contents)) - (syslogd (package-file inetutils "libexec/syslogd"))) - (return - (service - (documentation "Run the syslog daemon (syslogd).") - (provision '(syslogd)) - (start `(make-forkexec-constructor ,syslogd "--no-detach" - "--rcfile" ,syslog.conf)) - (stop `(make-kill-destructor)) - (inputs `(("inetutils" ,inetutils) - ("syslog.conf" ,syslog.conf))))))) - -(define* (guix-build-accounts count #:key - (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." - (with-monad %store-monad - (return (unfold (cut > <> count) - (lambda (n) - (user-account - (name (format #f "guixbuilder~2,'0d" n)) - (password "!") - (uid (+ first-uid n -1)) - (gid gid) - (comment (format #f "Guix Build User ~2d" n)) - (home-directory "/var/empty") - (shell (package-file shadow "sbin/nologin")) - (inputs `(("shadow" ,shadow))))) - 1+ - 1)))) - -(define* (guix-service #:key (guix guix) (builder-group "guixbuild") - (build-user-gid 30000) (build-accounts 10)) - "Return a service that runs the build daemon from GUIX, and has -BUILD-ACCOUNTS user accounts available under BUILD-USER-GID." - (mlet %store-monad ((daemon (package-file guix "bin/guix-daemon")) - (accounts (guix-build-accounts build-accounts - #:gid build-user-gid))) - (return (service - (provision '(guix-daemon)) - (start `(make-forkexec-constructor ,daemon - "--build-users-group" - ,builder-group)) - (stop `(make-kill-destructor)) - (inputs `(("guix" ,guix))) - (user-accounts accounts) - (user-groups (list (user-group - (name builder-group) - (id build-user-gid) - (members (map user-account-name - user-accounts))))))))) - -(define* (static-networking-service interface ip - #:key - gateway - (name-servers '()) - (inetutils inetutils) - (net-tools net-tools)) - "Return a service that starts INTERFACE with address IP. If GATEWAY is -true, it must be a string specifying the default network gateway." - - ;; TODO: Eventually we should do this using Guile's networking procedures, - ;; like 'configure-qemu-networking' does, but the patch that does this is - ;; not yet in stock Guile. - (mlet %store-monad ((ifconfig (package-file inetutils "bin/ifconfig")) - (route (package-file net-tools "sbin/route"))) - (return - (service - (documentation - (string-append "Set up networking on the '" interface - "' interface using a static IP address.")) - (provision '(networking)) - (start `(lambda _ - ;; Return #t if successfully started. - (and (zero? (system* ,ifconfig ,interface ,ip "up")) - ,(if gateway - `(zero? (system* ,route "add" "-net" "default" - "gw" ,gateway)) - #t) - ,(if (pair? name-servers) - `(call-with-output-file "/etc/resolv.conf" - (lambda (port) - (display - "# Generated by 'static-networking-service'.\n" - port) - (for-each (lambda (server) - (format port "nameserver ~a~%" - server)) - ',name-servers))) - #t)))) - (stop `(lambda _ - ;; Return #f is successfully stopped. - (not (and (system* ,ifconfig ,interface "down") - (system* ,route "del" "-net" "default"))))) - (respawn? #f) - (inputs `(("inetutils" ,inetutils) - ,@(if gateway - `(("net-tools" ,net-tools)) - '()))))))) - -(define* (xorg-start-command #:key - (guile guile-final) - (xorg-server xorg-server)) - "Return a derivation that builds a GUILE script to start the X server from -XORG-SERVER. Usually the X server is started by a login manager." - - (define (xserver.conf) - (text-file* "xserver.conf" " -Section \"Files\" - FontPath \"" font-adobe75dpi "/share/font/X11/75dpi\" - ModulePath \"" xf86-video-vesa "/lib/xorg/modules/drivers\" - ModulePath \"" xf86-input-mouse "/lib/xorg/modules/input\" - ModulePath \"" xf86-input-keyboard "/lib/xorg/modules/input\" - ModulePath \"" xorg-server "/lib/xorg/modules\" - ModulePath \"" xorg-server "/lib/xorg/modules/extensions\" - ModulePath \"" xorg-server "/lib/xorg/modules/multimedia\" -EndSection - -Section \"ServerFlags\" - Option \"AllowMouseOpenFail\" \"on"" -EndSection - -Section \"Monitor\" - Identifier \"Monitor[0]\" -EndSection - -Section \"InputClass\" - Identifier \"Generic keyboard\" - MatchIsKeyboard \"on\" - Option \"XkbRules\" \"base\" - Option \"XkbModel\" \"pc104\" -EndSection - -Section \"ServerLayout\" - Identifier \"Layout\" - Screen \"Screen-vesa\" -EndSection - -Section \"Device\" - Identifier \"Device-vesa\" - Driver \"vesa\" -EndSection - -Section \"Screen\" - Identifier \"Screen-vesa\" - Device \"Device-vesa\" -EndSection")) - - (mlet %store-monad ((guile-bin (package-file guile "bin/guile")) - (xorg-bin (package-file xorg-server "bin/X")) - (dri (package-file mesa "lib/dri")) - (xkbcomp-bin (package-file xkbcomp "bin")) - (xkb-dir (package-file xkeyboard-config - "share/X11/xkb")) - (config (xserver.conf))) - (define builder - ;; Write a small wrapper around the X server. - `(let ((out (assoc-ref %outputs "out"))) - (call-with-output-file out - (lambda (port) - (format port "#!~a --no-auto-compile~%!#~%" ,guile-bin) - (write '(begin - (setenv "XORG_DRI_DRIVER_PATH" ,dri) - (setenv "XKB_BINDIR" ,xkbcomp-bin) - - (apply execl - - ,xorg-bin "-ac" "-logverbose" "-verbose" - "-xkbdir" ,xkb-dir - "-config" ,(derivation->output-path config) - "-nolisten" "tcp" "-terminate" - - ;; Note: SLiM and other display managers add the - ;; '-auth' flag by themselves. - (cdr (command-line)))) - port))) - (chmod out #o555) - #t)) - - (mlet %store-monad ((inputs (lower-inputs - `(("xorg" ,xorg-server) - ("xkbcomp" ,xkbcomp) - ("xkeyboard-config" ,xkeyboard-config) - ("mesa" ,mesa) - ("guile" ,guile) - ("xorg.conf" ,config))))) - (derivation-expression "start-xorg" builder - #:inputs inputs)))) - -(define* (slim-service #:key (slim slim) - (allow-empty-passwords? #t) auto-login? - (default-user "") - (xauth xauth) (dmd dmd) (bash bash) - startx) - "Return a service that spawns the SLiM graphical login manager, which in -turn start the X display server with STARTX, a command as returned by -'xorg-start-command'. - -When ALLOW-EMPTY-PASSWORDS? is true, allow logins with an empty password. -When AUTO-LOGIN? is true, log in automatically as DEFAULT-USER." - (define (slim.cfg) - ;; TODO: Run "bash -login ~/.xinitrc %session". - (mlet %store-monad ((startx (or startx (xorg-start-command)))) - (text-file* "slim.cfg" " -default_path /run/current-system/bin -default_xserver " startx " -xserver_arguments :0 vt7 -xauth_path " xauth "/bin/xauth -authfile /var/run/slim.auth - -# The login command. '%session' is replaced by the chosen session name, one -# of the names specified in the 'sessions' setting: 'wmaker', 'xfce', etc. -login_cmd exec " ratpoison "/bin/ratpoison - -halt_cmd " dmd "/sbin/halt -reboot_cmd " dmd "/sbin/reboot -" (if auto-login? - (string-append "auto_login yes\ndefault_user " default-user) - "")))) - - (mlet %store-monad ((slim-bin (package-file slim "bin/slim")) - (bash-bin (package-file bash "bin/bash")) - (slim.cfg (slim.cfg))) - (return - (service - (documentation "Xorg display server") - (provision '(xorg-server)) - (requirement '(host-name)) - (start - ;; XXX: Work around the inability to specify env. vars. directly. - `(make-forkexec-constructor - ,bash-bin "-c" - ,(string-append "SLIM_CFGFILE=" (derivation->output-path slim.cfg) - " " slim-bin - " -nodaemon"))) - (stop `(make-kill-destructor)) - (inputs `(("slim" ,slim) - ("slim.cfg" ,slim.cfg) - ("bash" ,bash))) - (respawn? #t) - (pam-services - ;; Tell PAM about 'slim'. - (list (unix-pam-service - "slim" - #:allow-empty-passwords? allow-empty-passwords?))))))) - - -(define (dmd-configuration-file services etc) - "Return the dmd configuration file for SERVICES, that initializes /etc from -ETC on startup." - (define config - `(begin - (use-modules (ice-9 ftw)) - - (register-services - ,@(map (match-lambda - (($ documentation provision requirement - respawn? start stop) - `(make - #:docstring ,documentation - #:provides ',provision - #:requires ',requirement - #:respawn? ,respawn? - #:start ,start - #:stop ,stop))) - 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/nix/gcroots/etc-directory") - (symlink ,etc "/var/nix/gcroots/etc-directory")) - - (format #t "starting services...~%") - (for-each start ',(append-map service-provision services)))) - - (text-file "dmd.conf" (object->string config))) - -;;; dmd.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index dea7d0599..3c0ea8a35 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -44,8 +44,8 @@ #:use-module (gnu system linux) #:use-module (gnu system linux-initrd) #:use-module (gnu system grub) - #:use-module (gnu system dmd) #:use-module (gnu system) + #:use-module (gnu services) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 5bb14c438..7799ccbc4 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -36,7 +36,7 @@ (for-each (lambda (iface) (module-use! module (resolve-interface iface))) '((gnu system) - (gnu system dmd) + (gnu services) (gnu system shadow))) module)) -- cgit v1.3 From 0b14d1d7e36eb9b4fa38898d2a1e7e414cbbe735 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 19 Feb 2014 21:10:12 +0100 Subject: gnu: vm: Remove '%demo-operating-system'. * gnu/system/vm.scm (%demo-operating-system): Remove. (system-qemu-image, system-qemu-image/shared-store, system-qemu-image/shared-store-script): Adjust accordingly. --- gnu/system/vm.scm | 36 +++--------------------------------- 1 file changed, 3 insertions(+), 33 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 3c0ea8a35..b8b0274f1 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -414,36 +414,6 @@ such as /etc files." ;;; Stand-alone VM image. ;;; -(define %demo-operating-system - (operating-system - (host-name "gnu") - (timezone "Europe/Paris") - (locale "en_US.UTF-8") - (users (list (user-account - (name "guest") - (password "") - (uid 1000) (gid 100) - (comment "Guest of GNU") - (home-directory "/home/guest")))) - (packages (list coreutils - bash - guile-2.0 - dmd - gcc-final - ld-wrapper ; must come before BINUTILS - binutils-final - glibc-final - inetutils - findutils - grep - sed - procps - psmisc - zile - less - tzdata - guix)))) - (define (operating-system-build-gid os) "Return as a monadic value the group id for build users of OS, or #f." (anym %store-monad @@ -489,7 +459,7 @@ basic contents of the root file system of OS." ,@(append-map user-directories (operating-system-users os)))))) -(define* (system-qemu-image #:optional (os %demo-operating-system) +(define* (system-qemu-image os #:key (disk-image-size (* 900 (expt 2 20)))) "Return the derivation of a QEMU image of DISK-IMAGE-SIZE bytes of the GNU system as described by OS." @@ -505,7 +475,7 @@ system as described by OS." #:inputs-to-copy `(("system" ,os-drv))))) (define* (system-qemu-image/shared-store - #:optional (os %demo-operating-system) + os #:key (disk-image-size (* 15 (expt 2 20)))) "Return a derivation that builds a QEMU image of OS that shares its store with the host." @@ -520,7 +490,7 @@ with the host." #:disk-image-size disk-image-size))) (define* (system-qemu-image/shared-store-script - #:optional (os %demo-operating-system) + os #:key (qemu (package (inherit qemu) ;; FIXME/TODO: Use 9p instead of this hack. -- cgit v1.3