summaryrefslogtreecommitdiff
path: root/gnu/system
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/system')
-rw-r--r--gnu/system/examples/bare-bones.tmpl4
-rw-r--r--gnu/system/examples/desktop.tmpl7
-rw-r--r--gnu/system/examples/lightweight-desktop.tmpl7
-rw-r--r--gnu/system/examples/vm-image.tmpl2
-rw-r--r--gnu/system/install.scm5
-rw-r--r--gnu/system/locale.scm45
-rw-r--r--gnu/system/shadow.scm8
-rw-r--r--gnu/system/vm.scm94
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