diff options
Diffstat (limited to 'gnu/system')
| -rw-r--r-- | gnu/system/install.scm | 2 | ||||
| -rw-r--r-- | gnu/system/locale.scm | 49 | ||||
| -rw-r--r-- | gnu/system/shadow.scm | 4 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 87 |
4 files changed, 96 insertions, 46 deletions
diff --git a/gnu/system/install.scm b/gnu/system/install.scm index f9aa7f6733..6837385daf 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -306,7 +306,7 @@ Use Alt-F2 for documentation. ;; the appropriate one. (cons* (file-system (mount-point "/") - (device "GuixSD") + (device "GuixSD_image") (title 'label) (type "ext4")) diff --git a/gnu/system/locale.scm b/gnu/system/locale.scm index 3bb9f950a8..75cb855b59 100644 --- a/gnu/system/locale.scm +++ b/gnu/system/locale.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,10 +19,8 @@ (define-module (gnu system locale) #:use-module (guix gexp) #:use-module (guix store) - #:use-module (guix monads) #:use-module (guix records) #:use-module (guix packages) - #:use-module (guix utils) #:use-module (gnu packages base) #:use-module (gnu packages compression) #:use-module (srfi srfi-26) @@ -85,24 +83,15 @@ or #f on failure." (define* (localedef-command locale #:key (libc (canonical-package glibc))) "Return a gexp that runs 'localedef' from LIBC to build LOCALE." - (define (maybe-version-directory) - ;; XXX: For libc prior to 2.22, GuixSD did not store locale data in a - ;; version-specific sub-directory. Check whether this is the case. - ;; TODO: Remove this hack once libc 2.21 is buried. - (let ((version (package-version libc))) - (if (version>=? version "2.22") - (list version "/") - '()))) - #~(begin (format #t "building locale '~a'...~%" #$(locale-definition-name locale)) - (zero? (system* (string-append #$libc "/bin/localedef") + (zero? (system* (string-append #+libc "/bin/localedef") "--no-archive" "--prefix" #$output "-i" #$(locale-definition-source locale) "-f" #$(locale-definition-charset locale) (string-append #$output "/" - #$@(maybe-version-directory) + #$(package-version libc) "/" #$(locale-definition-name locale)))))) (define* (single-locale-directory locales @@ -119,12 +108,7 @@ of LIBC." #~(begin (mkdir #$output) - ;; XXX: For libcs < 2.22, locale data is stored in the top-level - ;; directory. - ;; TODO: Remove this hack once libc 2.21 is buried. - #$(if (version>=? version "2.22") - #~(mkdir (string-append #$output "/" #$version)) - #~(symlink "." (string-append #$output "/" #$version))) + (mkdir (string-append #$output "/" #$version)) ;; 'localedef' executes 'gzip' to access compressed locale sources. (setenv "PATH" (string-append #$gzip "/bin")) @@ -133,8 +117,7 @@ of LIBC." (and #$@(map (cut localedef-command <> #:libc libc) locales))))) - (gexp->derivation (string-append "locale-" version) build - #:local-build? #t)) + (computed-file (string-append "locale-" version) build)) (define* (locale-directory locales #:key (libcs %default-locale-libcs)) @@ -148,18 +131,16 @@ data format changes between libc versions." ((libc) (single-locale-directory locales #:libc libc)) ((libcs ..1) - (mlet %store-monad ((dirs (mapm %store-monad - (lambda (libc) - (single-locale-directory locales - #:libc libc)) - libcs))) - (gexp->derivation "locale-multiple-versions" - (with-imported-modules '((guix build union)) - #~(begin - (use-modules (guix build union)) - (union-build #$output (list #$@dirs)))) - #:local-build? #t - #:substitutable? #f))))) + (let ((dirs (map (lambda (libc) + (single-locale-directory locales #:libc libc)) + libcs))) + (computed-file "locale-multiple-versions" + (with-imported-modules '((guix build union)) + #~(begin + (use-modules (guix build union)) + (union-build #$output (list #$@dirs)))) + #:options '(#:local-build? #t + #:substitutable? #f)))))) (define %default-locale-libcs ;; The libcs for which we build locales by default. diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index b30ef8e390..712e6df8d8 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Alex Griffin <a@ajgrf.com> ;;; ;;; This file is part of GNU Guix. @@ -143,7 +143,7 @@ (with-imported-modules '((guix build utils)) #~(begin (use-modules (guix build utils)) - (copy-file (car (find-files #$guile-wm "wm-init-sample.scm")) + (copy-file (car (find-files #+guile-wm "wm-init-sample.scm")) #$output)))) (let ((profile (plain-file "bash_profile" "\ diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 66a2448ceb..90d29b0783 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -39,7 +39,7 @@ #:use-module (gnu packages gawk) #:use-module (gnu packages bash) #:use-module (gnu packages less) - #:use-module (gnu packages qemu) + #:use-module (gnu packages virtualization) #:use-module (gnu packages disk) #:use-module (gnu packages zile) #:use-module (gnu packages linux) @@ -68,7 +68,10 @@ system-qemu-image/shared-store system-qemu-image/shared-store-script - system-disk-image)) + system-disk-image + + virtual-machine + virtual-machine?)) ;;; Commentary: @@ -105,16 +108,19 @@ (guile-for-build (%guile-for-build)) + (single-file-output? #f) (make-disk-image? #f) (references-graphs #f) (memory-size 256) (disk-image-format "qcow2") (disk-image-size 'guess)) "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a -derivation). In the virtual machine, EXP has access to all its inputs from the -store; it should put its output files in the `/xchg' directory, which is -copied to the derivation's output when the VM terminates. The virtual machine -runs with MEMORY-SIZE MiB of memory. +derivation). The virtual machine runs with MEMORY-SIZE MiB of memory. In the +virtual machine, EXP has access to all its inputs from the store; it should +put its output file(s) in the '/xchg' directory. + +If SINGLE-FILE-OUTPUT? is true, copy a single file from '/xchg' to OUTPUT. +Otherwise, copy the contents of /xchg to a new directory OUTPUT. When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of type DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), of DISK-IMAGE-SIZE bytes and @@ -164,6 +170,7 @@ made available under the /xchg CIFS share." #:linux linux #:initrd initrd #:memory-size #$memory-size #:make-disk-image? #$make-disk-image? + #:single-file-output? #$single-file-output? #:disk-image-format #$disk-image-format #:disk-image-size size #:references-graphs graphs))))) @@ -219,6 +226,7 @@ INPUTS is a list of inputs (as for packages)." (reboot)))) #:system system #:make-disk-image? #f + #:single-file-output? #t #:references-graphs inputs)) (define* (qemu-image #:key @@ -345,7 +353,7 @@ to USB sticks meant to be read-only." ;; Volume name of the root file system. Since we don't know which device ;; will hold it, we use the volume name to find it (using the UUID would ;; be even better, but somewhat less convenient.) - (normalize-label "GuixSD")) + (normalize-label "GuixSD_image")) (define file-systems-to-keep (remove (lambda (fs) @@ -576,7 +584,8 @@ with '-virtfs' options for the host file systems listed in SHARED-FS." full-boot? (disk-image-size (* (if full-boot? 500 70) - (expt 2 20)))) + (expt 2 20))) + (options '())) "Return a derivation that builds a script to run a virtual machine image of OS that shares its store with the host. The virtual machine runs with MEMORY-SIZE MiB of memory. @@ -609,7 +618,8 @@ it is mostly useful when FULL-BOOT? is true." #$@(common-qemu-options image (map file-system-mapping-source (cons %store-mapping mappings))) - "-m " (number->string #$memory-size))) + "-m " (number->string #$memory-size) + #$@options)) (define builder #~(call-with-output-file #$output @@ -621,4 +631,63 @@ it is mostly useful when FULL-BOOT? is true." (gexp->derivation "run-vm.sh" builder))) + +;;; +;;; High-level abstraction. +;;; + +(define-record-type* <virtual-machine> %virtual-machine + make-virtual-machine + virtual-machine? + (operating-system virtual-machine-operating-system) ;<operating-system> + (qemu virtual-machine-qemu ;<package> + (default qemu)) + (graphic? virtual-machine-graphic? ;Boolean + (default #f)) + (memory-size virtual-machine-memory-size ;integer (MiB) + (default 256)) + (port-forwardings virtual-machine-port-forwardings ;list of integer pairs + (default '()))) + +(define-syntax virtual-machine + (syntax-rules () + "Declare a virtual machine running the specified OS, with the given +options." + ((_ os) ;shortcut + (%virtual-machine (operating-system os))) + ((_ fields ...) + (%virtual-machine fields ...)))) + +(define (port-forwardings->qemu-options forwardings) + "Return the QEMU option for the given port FORWARDINGS as a string, where +FORWARDINGS is a list of host-port/guest-port pairs." + (string-join + (map (match-lambda + ((host-port . guest-port) + (string-append "hostfwd=tcp::" + (number->string host-port) + "-:" (number->string guest-port)))) + forwardings) + ",")) + +(define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>) + system target) + ;; XXX: SYSTEM and TARGET are ignored. + (match vm + (($ <virtual-machine> os qemu graphic? memory-size ()) + (system-qemu-image/shared-store-script os + #:qemu qemu + #:graphic? graphic? + #:memory-size memory-size)) + (($ <virtual-machine> os qemu graphic? memory-size forwardings) + (let ((options + `("-net" ,(string-append + "user," + (port-forwardings->qemu-options forwardings))))) + (system-qemu-image/shared-store-script os + #:qemu qemu + #:graphic? graphic? + #:memory-size memory-size + #:options options))))) + ;;; vm.scm ends here |