X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/a348b09ea9c1dd51c4ce8e16f2f0629c64b9feb6..44ddf33ed5b86fd79921aba5572a82c2a940808c:/gnu/system/vm.scm diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 502c13b973..5407522652 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. ;;; @@ -25,24 +25,27 @@ #:use-module ((gnu packages base) #:select (%final-inputs guile-final gcc-final glibc-final - coreutils findutils grep sed)) + ld-wrapper binutils-final + coreutils findutils grep sed tzdata)) #:use-module (gnu packages guile) #:use-module (gnu packages bash) + #:use-module (gnu packages less) #:use-module (gnu packages qemu) #:use-module (gnu packages parted) #: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)) - #:use-module (gnu packages system) + #:use-module (gnu packages admin) #: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) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -59,27 +62,12 @@ ;;; ;;; Code: -(define (lower-inputs inputs) - "Turn any package from INPUTS into a derivation; return the corresponding -input list as a monadic value." - (with-monad %store-monad - (sequence %store-monad - (map (match-lambda - ((name (? package? package) sub-drv ...) - (mlet %store-monad ((drv (package->derivation package))) - (return `(,name ,drv ,@sub-drv)))) - ((name (? string? file)) - (return `(,name ,file))) - (tuple - (return tuple))) - inputs)))) - (define* (expression->derivation-in-linux-vm name exp #:key (system (%current-system)) (inputs '()) (linux linux-libre) - (initrd qemu-initrd) + initrd (qemu qemu/smb-shares) (env-vars '()) (modules '()) @@ -90,10 +78,10 @@ input list as a monadic value." (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. @@ -166,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 @@ -190,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 ; use the default initrd? + (return initrd) + (qemu-initrd #:guile-modules-in-chroot? #t))) (inputs (lower-inputs `(("qemu" ,qemu) ("linux" ,linux) ("initrd" ,initrd) @@ -197,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 @@ -217,7 +209,7 @@ made available under the /xchg CIFS share." (inputs-to-copy '())) "Return a bootable, stand-alone QEMU image. The returned image is a full disk image, with a GRUB installation that uses GRUB-CONFIGURATION as its -configuration file. +configuration file (GRUB-CONFIGURATION must be the name of a file in the VM.) INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied into the image being built. When INITIALIZE-STORE? is true, initialize the @@ -262,7 +254,7 @@ such as /etc files." "/sbin/grub-install")) (umount (string-append (assoc-ref %build-inputs "util-linux") "/bin/umount")) ; XXX: add to Guile - (grub.cfg (assoc-ref %build-inputs "grub.cfg"))) + (grub.cfg ,grub-configuration)) (define (read-reference-graph port) ;; Return a list of store paths from the reference graph at PORT. @@ -302,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") @@ -324,7 +316,7 @@ such as /etc files." (copy-recursively thing (string-append "/fs" thing))) - (cons grub.cfg (things-to-copy))) + (things-to-copy)) ;; Populate /dev. (make-essential-device-nodes #:root "/fs") @@ -387,14 +379,13 @@ 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 #:inputs `(("parted" ,parted) ("grub" ,grub) ("e2fsprogs" ,e2fsprogs) - ("grub.cfg" ,grub-configuration) ;; For shell scripts. ("sed" ,(car (assoc-ref %final-inputs "sed"))) @@ -420,255 +411,67 @@ such as /etc files." ;;; Stand-alone VM image. ;;; -(define* (union inputs - #:key (guile (%guile-for-build)) (system (%current-system)) - (name "union")) - "Return a derivation that builds the union of INPUTS. INPUTS is a list of -input tuples." - (define builder - '(begin - (use-modules (guix build union)) - - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - - (let ((output (assoc-ref %outputs "out")) - (inputs (map cdr %build-inputs))) - (format #t "building union `~a' with ~a packages...~%" - output (length inputs)) - (union-build output inputs)))) - - (mlet %store-monad - ((inputs (sequence %store-monad - (map (match-lambda - ((name (? package? p)) - (mlet %store-monad - ((drv (package->derivation p system))) - (return `(,name ,drv)))) - ((name (? package? p) output) - (mlet %store-monad - ((drv (package->derivation p system))) - (return `(,name ,drv ,output)))) - (x - (return x))) - inputs)))) - (derivation-expression name builder - #:system system - #:inputs inputs - #:modules '((guix build union)) - #:guile-for-build guile))) - -(define* (file-union files - #:key (inputs '()) (name "file-union")) - "Return a derivation that builds a directory containing all of FILES. Each -item in FILES must be a list where the first element is the file name to use -in the new directory, and the second element is the target file. - -The subset of FILES corresponding to plain store files is automatically added -as an inputs; additional inputs, such as derivations, are taken from INPUTS." - (mlet %store-monad ((inputs (lower-inputs inputs))) - (let ((inputs (append inputs - (filter (match-lambda - ((_ file) - (direct-store-path? file))) - files)))) - (derivation-expression name - `(let ((out (assoc-ref %outputs "out"))) - (mkdir out) - (chdir out) - ,@(map (match-lambda - ((name target) - `(symlink ,target ,name))) - files)) - - #:inputs inputs)))) - -(define* (etc-directory #:key - (accounts '()) - (groups '()) - (pam-services '()) - (profile "/var/run/current-system/profile")) - "Return a derivation that builds the static part of the /etc directory." - (mlet* %store-monad - ((services (package-file net-base "etc/services")) - (protocols (package-file net-base "etc/protocols")) - (rpc (package-file net-base "etc/rpc")) - (passwd (passwd-file accounts)) - (shadow (passwd-file accounts #:shadow? #t)) - (group (group-file groups)) - (pam.d (pam-services->directory pam-services)) - (login.defs (text-file "login.defs" "# Empty for now.\n")) - (issue (text-file "issue" " -This is an alpha preview of the GNU system. Welcome. - -This image features the GNU Guix package manager, which was used to -build it (http://www.gnu.org/software/guix/). The init system is -GNU dmd (http://www.gnu.org/software/dmd/). - -You can log in as 'guest' or 'root' with no password. -")) - - ;; TODO: Generate bashrc from packages' search-paths. - (bashrc (text-file "bashrc" (string-append " -export PS1='\\u@\\h\\$ ' -export PATH=$HOME/.guix-profile/bin:" profile "/bin:" profile "/sbin -export CPATH=$HOME/.guix-profile/include:" profile "/include -export LIBRARY_PATH=$HOME/.guix-profile/lib:" profile "/lib -alias ls='ls -p --color' -alias ll='ls -l' -"))) - - (files -> `(("services" ,services) - ("protocols" ,protocols) - ("rpc" ,rpc) - ("pam.d" ,(derivation->output-path pam.d)) - ("login.defs" ,login.defs) - ("issue" ,issue) - ("profile" ,bashrc) - ("passwd" ,passwd) - ("shadow" ,shadow) - ("group" ,group)))) - (file-union files - #:inputs `(("net" ,net-base) - ("pam.d" ,pam.d)) - #:name "etc"))) - -(define (system-qemu-image) - "Return the derivation of a QEMU image of the GNU system." - (define build-user-gid 30000) - +(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* (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 +system as described by OS." (mlet* %store-monad - ((services (listm %store-monad - (host-name-service "gnu") - (mingetty-service "tty1") - (mingetty-service "tty2") - (mingetty-service "tty3") - (mingetty-service "tty4") - (mingetty-service "tty5") - (mingetty-service "tty6") - (syslog-service) - (guix-service) - (nscd-service) - - ;; QEMU networking settings. - (static-networking-service "eth0" "10.0.2.10" - #:name-servers '("10.0.2.3") - #:gateway "10.0.2.2"))) - (motd (text-file "motd" " -Happy birthday, GNU! http://www.gnu.org/gnu30 - -")) - (pam-services -> - ;; Services known to PAM. - (list %pam-other-services - (unix-pam-service "login" - #:allow-empty-passwords? #t - #:motd motd))) - - (build-accounts (guix-build-accounts 10 #:gid build-user-gid)) - - (bash-file (package-file bash "bin/bash")) - (dmd-file (package-file dmd "bin/dmd")) - (dmd-conf (dmd-configuration-file services)) - (accounts -> (cons* (user-account - (name "root") - (password "") - (uid 0) (gid 0) - (comment "System administrator") - (home-directory "/") - (shell bash-file)) - (user-account - (name "guest") - (password "") - (uid 1000) (gid 100) - (comment "Guest of GNU") - (home-directory "/home/guest") - (shell bash-file)) - build-accounts)) - (groups -> (list (user-group - (name "root") - (id 0)) - (user-group - (name "users") - (id 100) - (members '("guest"))) - (user-group - (name "guixbuild") - (id build-user-gid) - (members (map user-account-name - build-accounts))))) - (packages -> `(("coreutils" ,coreutils) - ("bash" ,bash) - ("guile" ,guile-2.0) - ("dmd" ,dmd) - ("gcc" ,gcc-final) - ("libc" ,glibc-final) - ("inetutils" ,inetutils) - ("findutils" ,findutils) - ("grep" ,grep) - ("sed" ,sed) - ("procps" ,procps) - ("psmisc" ,psmisc) - ("zile" ,zile) - ("guix" ,guix))) - - ;; TODO: Replace with a real profile with a manifest. - (profile-drv (union packages - #:name "default-profile")) - (profile -> (derivation->output-path profile-drv)) - (etc-drv (etc-directory #:accounts accounts #:groups groups - #:pam-services pam-services - #:profile profile)) - (etc -> (derivation->output-path etc-drv)) - - + ((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") - ("/etc/static" -> ,etc) - ("/etc/shadow" -> "/etc/static/shadow") - ("/etc/passwd" -> "/etc/static/passwd") - ("/etc/group" -> "/etc/static/group") - ("/etc/login.defs" -> "/etc/static/login.defs") - ("/etc/pam.d" -> "/etc/static/pam.d") - ("/etc/profile" -> "/etc/static/profile") - ("/etc/issue" -> "/etc/static/issue") - ("/etc/services" -> "/etc/static/services") - ("/etc/protocols" -> "/etc/static/protocols") - ("/etc/rpc" -> "/etc/static/rpc") (directory "/var/nix/gcroots") - ("/var/nix/gcroots/default-profile" -> ,profile) - ("/var/nix/gcroots/etc-directory" -> ,etc) + ("/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))) - (boot (text-file "boot" (object->string - `(execl ,dmd-file "dmd" - "--config" ,dmd-conf)))) - (entries -> (list (return (menu-entry - (label (string-append - "GNU system with Linux-Libre " - (package-version linux-libre) - " (technology preview)")) - (linux linux-libre) - (linux-arguments `("--root=/dev/vda1" - ,(string-append "--load=" boot))) - (initrd gnu-system-initrd))))) - (grub.cfg (grub-configuration-file entries))) + (directory "/home/guest" 1000 100)))) (qemu-image #:grub-configuration grub.cfg #:populate populate - #:disk-image-size (* 550 (expt 2 20)) + #:disk-image-size disk-image-size #:initialize-store? #t - #:inputs-to-copy `(("boot" ,boot) - ("linux" ,linux-libre) - ("initrd" ,gnu-system-initrd) - ("dmd.conf" ,dmd-conf) - ("profile" ,profile-drv) - ("etc" ,etc-drv) - ,@(append-map service-inputs - services))))) + #:inputs-to-copy `(("system" ,os-drv))))) ;;; vm.scm ends here