diff options
Diffstat (limited to 'gnu/system')
-rw-r--r-- | gnu/system/examples/bare-bones.tmpl | 4 | ||||
-rw-r--r-- | gnu/system/examples/desktop.tmpl | 7 | ||||
-rw-r--r-- | gnu/system/examples/lightweight-desktop.tmpl | 7 | ||||
-rw-r--r-- | gnu/system/examples/vm-image.tmpl | 2 | ||||
-rw-r--r-- | gnu/system/install.scm | 5 | ||||
-rw-r--r-- | gnu/system/locale.scm | 45 | ||||
-rw-r--r-- | gnu/system/shadow.scm | 8 | ||||
-rw-r--r-- | gnu/system/vm.scm | 94 |
8 files changed, 119 insertions, 53 deletions
diff --git a/gnu/system/examples/bare-bones.tmpl b/gnu/system/examples/bare-bones.tmpl index f7b8823d4f..459d241885 100644 --- a/gnu/system/examples/bare-bones.tmpl +++ b/gnu/system/examples/bare-bones.tmpl @@ -12,7 +12,9 @@ ;; Assuming /dev/sdX is the target hard disk, and "my-root" is ;; the label of the target root file system. - (bootloader (grub-configuration (device "/dev/sdX"))) + (bootloader (bootloader-configuration + (bootloader grub-bootloader) + (target "/dev/sdX"))) (file-systems (cons (file-system (device "my-root") (title 'label) diff --git a/gnu/system/examples/desktop.tmpl b/gnu/system/examples/desktop.tmpl index 8b02659478..2131d1f18f 100644 --- a/gnu/system/examples/desktop.tmpl +++ b/gnu/system/examples/desktop.tmpl @@ -13,19 +13,20 @@ ;; Assuming /dev/sdX is the target hard disk, and "my-root" ;; is the label of the target root file system. - (bootloader (grub-configuration (device "/dev/sdX"))) + (bootloader (bootloader-configuration + (bootloader grub-bootloader) + (target "/dev/sdX"))) ;; Specify a mapped device for the encrypted root partition. ;; The UUID is that returned by 'cryptsetup luksUUID'. (mapped-devices (list (mapped-device (source (uuid "12345678-1234-1234-1234-123456789abc")) - (target "the-root-device") + (target "my-root") (type luks-device-mapping)))) (file-systems (cons (file-system (device "my-root") - (title 'label) (mount-point "/") (type "ext4") (dependencies mapped-devices)) diff --git a/gnu/system/examples/lightweight-desktop.tmpl b/gnu/system/examples/lightweight-desktop.tmpl index 6fb6283d29..fb7cfebf6d 100644 --- a/gnu/system/examples/lightweight-desktop.tmpl +++ b/gnu/system/examples/lightweight-desktop.tmpl @@ -12,9 +12,10 @@ (locale "en_US.utf8") ;; Use the UEFI variant of GRUB with the EFI System - ;; Partition on /dev/sda1. - (bootloader (grub-configuration (grub grub-efi) - (device "/dev/sda1"))) + ;; Partition mounted on /boot/efi. + (bootloader (bootloader-configuration + (bootloader grub-efi-bootloader) + (target "/boot/efi"))) ;; Assume the target root file system is labelled "my-root". (file-systems (cons* (file-system diff --git a/gnu/system/examples/vm-image.tmpl b/gnu/system/examples/vm-image.tmpl index 57ac71c535..056b439c5f 100644 --- a/gnu/system/examples/vm-image.tmpl +++ b/gnu/system/examples/vm-image.tmpl @@ -26,7 +26,7 @@ partprobe, and then 2) resizing the filesystem with resize2fs.\n")) ;; Assuming /dev/sdX is the target hard disk, and "my-root" is ;; the label of the target root file system. - (bootloader (grub-configuration (device "/dev/sda") + (bootloader (grub-configuration (target "/dev/sda") (terminal-outputs '(console)))) (file-systems (cons (file-system (device "my-root") diff --git a/gnu/system/install.scm b/gnu/system/install.scm index f9aa7f6733..7f6ffe9582 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -299,14 +299,13 @@ Use Alt-F2 for documentation. (host-name "gnu") (timezone "Europe/Paris") (locale "en_US.utf8") - (bootloader (grub-configuration - (device "/dev/sda"))) + (bootloader (grub-configuration (target "/dev/sda"))) (file-systems ;; Note: the disk image build code overrides this root file system with ;; 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 51482879f7..75cb855b59 100644 --- a/gnu/system/locale.scm +++ b/gnu/system/locale.scm @@ -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,15 +83,6 @@ 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)) @@ -102,7 +91,7 @@ or #f on failure." "-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 712e6df8d8..236807c70a 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -174,7 +174,8 @@ else PS1='\\u@\\h \\w\\$ ' fi alias ls='ls -p --color' -alias ll='ls -l'\n")) +alias ll='ls -l' +alias grep='grep --color'\n")) (zlogin (plain-file "zlogin" "\ # Honor system-wide environment variables source /etc/profile\n")) @@ -189,6 +190,11 @@ set debug-file-directory ~/.guix-profile/lib/debug\n"))) (".bashrc" ,bashrc) (".zlogin" ,zlogin) (".Xdefaults" ,xdefaults) + (".guile" ,(plain-file "dot-guile" + (string-append + "(use-modules (ice-9 readline))\n\n" + ";; Enable completion at the REPL.\n" + "(activate-readline)\n"))) (".guile-wm" ,guile-wm) (".gdbinit" ,gdbinit)))) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 66a2448ceb..4494af0031 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) @@ -49,6 +49,7 @@ #:use-module (gnu packages admin) #:use-module (gnu bootloader) + #:use-module ((gnu bootloader grub) #:select (grub-mkrescue-bootloader)) #:use-module (gnu system shadow) #:use-module (gnu system pam) #:use-module (gnu system linux-initrd) @@ -68,7 +69,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 +109,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 +171,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 +227,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 +354,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) @@ -361,6 +370,12 @@ to USB sticks meant to be read-only." #:volatile-root? #t rest))) + (bootloader (if (string=? "iso9660" file-system-type) + (bootloader-configuration + (inherit (operating-system-bootloader os)) + (bootloader grub-mkrescue-bootloader)) + (operating-system-bootloader os))) + ;; Force our own root file system. (file-systems (cons (file-system (mount-point "/") @@ -576,7 +591,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 +625,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 +638,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 |