summaryrefslogtreecommitdiff
path: root/gnu/system
diff options
context:
space:
mode:
authorChristopher Baines <mail@cbaines.net>2020-11-29 14:19:55 +0000
committerChristopher Baines <mail@cbaines.net>2020-11-29 17:34:18 +0000
commitff01206345e2306cc633db48e0b29eab9077091a (patch)
tree25c7ee17005dadc9bf4fae3f0873e03a4704f782 /gnu/system
parented2545f0fa0e2ad99d5a0c45f532c539b299b9fb (diff)
parent7c2e67400ffaef8eb6f30ef7126c976ee3d7e36c (diff)
Merge remote-tracking branch 'origin/master' into core-updates
Diffstat (limited to 'gnu/system')
-rw-r--r--gnu/system/examples/yggdrasil.tmpl60
-rw-r--r--gnu/system/image.scm29
-rw-r--r--gnu/system/images/pinebook-pro.scm66
-rw-r--r--gnu/system/linux-initrd.scm11
-rw-r--r--gnu/system/mapped-devices.scm199
-rw-r--r--gnu/system/uuid.scm8
-rw-r--r--gnu/system/vm.scm92
7 files changed, 306 insertions, 159 deletions
diff --git a/gnu/system/examples/yggdrasil.tmpl b/gnu/system/examples/yggdrasil.tmpl
new file mode 100644
index 0000000000..be80bf4de9
--- /dev/null
+++ b/gnu/system/examples/yggdrasil.tmpl
@@ -0,0 +1,60 @@
+;; This is an operating system configuration template
+;; for a "bare bones" setup, with no X11 display server.
+
+(use-modules (gnu))
+(use-service-modules networking ssh)
+(use-package-modules admin curl networking screen)
+
+(operating-system
+ (host-name "ruby-guard-5545")
+ (timezone "Europe/Budapest")
+ (locale "en_US.utf8")
+
+ ;; Boot in "legacy" BIOS mode, assuming /dev/sdX is the
+ ;; target hard disk, and "my-root" is the label of the target
+ ;; root file system.
+ (bootloader (bootloader-configuration
+ (bootloader grub-bootloader)
+ (target "/dev/sdX")))
+ (file-systems (cons (file-system
+ (device (file-system-label "my-root"))
+ (mount-point "/")
+ (type "ext4"))
+ %base-file-systems))
+ (users (cons (user-account
+ (name "alice")
+ (comment "Bob's sister")
+ (group "users")
+ ;; adding her to the yggdrasil group means she can use
+ ;; yggdrasilctl to modify the configuration
+ (supplementary-groups '("wheel" "yggdrasil")))
+ %base-user-accounts))
+
+ ;; Globally-installed packages.
+ (packages (cons* screen curl %base-packages))
+
+ ;; Add services to the baseline: a DHCP client and
+ ;; an SSH server.
+ ;; If you add an /etc/yggdrasil-private.conf, you can log in to ssh
+ ;; using your Yggdrasil IPv6 address from another machine running Yggdrasil.
+ ;; Alternatively, the client can sit behind a router that has Yggdrasil.
+ ;; That file is specifically _not_ handled by Guix, because we don't want its
+ ;; contents to sit in the world-readable /gnu/store.
+ (services
+ (append
+ (list
+ (service dhcp-client-service-type)
+ (service yggdrasil-service-type
+ (yggdrasil-configuration
+ (log-to 'stdout)
+ (log-level 'debug)
+ (autoconf? #f)
+ (json-config
+ ;; choose a few from
+ ;; https://github.com/yggdrasil-network/public-peers
+ '((peers . #("tcp://1.2.3.4:1337"))))
+ (config-file #f)))
+ (service openssh-service-type
+ (openssh-configuration
+ (port-number 2222))))
+ %base-services)))
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index bc6610b14c..4972d9067b 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -66,6 +66,7 @@
efi-disk-image
iso9660-image
+ arm32-disk-image
arm64-disk-image
image-with-os
@@ -73,6 +74,7 @@
qcow2-image-type
iso-image-type
uncompressed-iso-image-type
+ arm32-image-type
arm64-image-type
image-with-label
@@ -126,10 +128,10 @@
(label "GUIX_IMAGE")
(flags '(boot)))))))
-(define arm64-disk-image
+(define arm32-disk-image
(image
(format 'disk-image)
- (target "aarch64-linux-gnu")
+ (target "arm-linux-gnueabihf")
(partitions
(list (partition
(inherit root-partition)
@@ -138,6 +140,11 @@
;; fails.
(volatile-root? #f)))
+(define arm64-disk-image
+ (image
+ (inherit arm32-disk-image)
+ (target "aarch64-linux-gnu")))
+
;;;
;;; Images types.
@@ -179,9 +186,14 @@ set to the given OS."
(compression? #f))
<>))))
+(define arm32-image-type
+ (image-type
+ (name 'arm32-raw)
+ (constructor (cut image-with-os arm32-disk-image <>))))
+
(define arm64-image-type
(image-type
- (name 'arm)
+ (name 'arm64-raw)
(constructor (cut image-with-os arm64-disk-image <>))))
@@ -342,6 +354,9 @@ used in the image."
#$output
image-root)))))
(computed-file "partition.img" image-builder
+ ;; Allow offloading so that this I/O-intensive process
+ ;; doesn't run on the build farm's head node.
+ #:local-build? #f
#:options `(#:references-graphs ,inputs))))
(define (partition->config partition)
@@ -399,6 +414,7 @@ image ~a {
out-image))
(convert-disk-image out-image '#$format #$output)))))
(computed-file name builder
+ #:local-build? #f ;too I/O-intensive
#:options `(#:substitutable? ,substitutable?))))
@@ -476,6 +492,9 @@ used in the image. "
#:volume-id #$root-label
#:volume-uuid #$root-uuid)))))
(computed-file name builder
+ ;; Allow offloading so that this I/O-intensive process
+ ;; doesn't run on the build farm's head node.
+ #:local-build? #f
#:options `(#:references-graphs ,inputs
#:substitutable? ,substitutable?))))
@@ -557,7 +576,9 @@ it can be used for bootloading."
(file-systems-to-keep
(srfi-1:remove
(lambda (fs)
- (string=? (file-system-mount-point fs) "/"))
+ (let ((mount-point (file-system-mount-point fs)))
+ (or (string=? mount-point "/")
+ (string=? mount-point "/boot/efi"))))
(operating-system-file-systems base-os)))
(format (image-format image))
(os
diff --git a/gnu/system/images/pinebook-pro.scm b/gnu/system/images/pinebook-pro.scm
new file mode 100644
index 0000000000..b038e262cb
--- /dev/null
+++ b/gnu/system/images/pinebook-pro.scm
@@ -0,0 +1,66 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(define-module (gnu system images pinebook-pro)
+ #:use-module (gnu bootloader)
+ #:use-module (gnu bootloader u-boot)
+ #:use-module (gnu image)
+ #:use-module (gnu packages linux)
+ #:use-module (gnu services)
+ #:use-module (gnu services base)
+ #:use-module (gnu system)
+ #:use-module (gnu system file-systems)
+ #:use-module (gnu system image)
+ #:use-module (srfi srfi-26)
+ #:export (pinebook-pro-barebones-os
+ pinebook-pro-image-type
+ pinebook-pro-barebones-raw-image))
+
+(define pinebook-pro-barebones-os
+ (operating-system
+ (host-name "viso")
+ (timezone "Europe/Paris")
+ (locale "en_US.utf8")
+ (bootloader (bootloader-configuration
+ (bootloader u-boot-pinebook-pro-rk3399-bootloader)
+ (target "/dev/vda")))
+ (initrd-modules '())
+ (kernel linux-libre-arm64-generic)
+ (file-systems (cons (file-system
+ (device (file-system-label "my-root"))
+ (mount-point "/")
+ (type "ext4"))
+ %base-file-systems))
+ (services (cons (service agetty-service-type
+ (agetty-configuration
+ (extra-options '("-L")) ; no carrier detect
+ (baud-rate "115200")
+ (term "vt100")
+ (tty "ttyS0")))
+ %base-services))))
+
+(define pinebook-pro-image-type
+ (image-type
+ (name 'pinebook-pro-raw)
+ (constructor (cut image-with-os arm64-disk-image <>))))
+
+(define pinebook-pro-barebones-raw-image
+ (image
+ (inherit
+ (os->image pinebook-pro-barebones-os #:type pinebook-pro-image-type))
+ (name 'pinebook-pro-barebones-raw-image)))
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index b8a30c0abc..85e493fecb 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -195,11 +195,11 @@ upon error."
(define device-mapping-commands
;; List of gexps to open the mapped devices.
(map (lambda (md)
- (let* ((source (mapped-device-source md))
- (target (mapped-device-target md))
- (type (mapped-device-type md))
- (open (mapped-device-kind-open type)))
- (open source target)))
+ (let* ((source (mapped-device-source md))
+ (targets (mapped-device-targets md))
+ (type (mapped-device-type md))
+ (open (mapped-device-kind-open type)))
+ (open source targets)))
mapped-devices))
(define kodir
@@ -217,6 +217,7 @@ upon error."
(gnu system file-systems)
((guix build utils) #:hide (delete))
(guix build bournish) ;add the 'bournish' meta-command
+ (srfi srfi-1) ;for lvm-device-mapping
(srfi srfi-26)
;; FIXME: The following modules are for
diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm
index 31c50c4e40..559c27bb28 100644
--- a/gnu/system/mapped-devices.scm
+++ b/gnu/system/mapped-devices.scm
@@ -28,6 +28,7 @@
formatted-message
&fix-hint
&error-location))
+ #:use-module (guix deprecation)
#:use-module (gnu services)
#:use-module (gnu services shepherd)
#:use-module (gnu system uuid)
@@ -35,17 +36,19 @@
#:autoload (gnu build linux-modules)
(missing-modules)
#:autoload (gnu packages cryptsetup) (cryptsetup-static)
- #:autoload (gnu packages linux) (mdadm-static)
+ #:autoload (gnu packages linux) (mdadm-static lvm2-static)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
- #:export (mapped-device
+ #:export (%mapped-device
+ mapped-device
mapped-device?
mapped-device-source
mapped-device-target
+ mapped-device-targets
mapped-device-type
mapped-device-location
@@ -61,7 +64,8 @@
check-device-initrd-modules ;XXX: needs a better place
luks-device-mapping
- raid-device-mapping))
+ raid-device-mapping
+ lvm-device-mapping))
;;; Commentary:
;;;
@@ -70,15 +74,36 @@
;;;
;;; Code:
-(define-record-type* <mapped-device> mapped-device
+(define-record-type* <mapped-device> %mapped-device
make-mapped-device
mapped-device?
(source mapped-device-source) ;string | list of strings
- (target mapped-device-target) ;string
+ (targets mapped-device-targets) ;list of strings
(type mapped-device-type) ;<mapped-device-kind>
(location mapped-device-location
(default (current-source-location)) (innate)))
+(define-syntax mapped-device-compatibility-helper
+ (syntax-rules (target)
+ ((_ () (fields ...))
+ (%mapped-device fields ...))
+ ((_ ((target exp) rest ...) (others ...))
+ (%mapped-device others ...
+ (targets (list exp))
+ rest ...))
+ ((_ (field rest ...) (others ...))
+ (mapped-device-compatibility-helper (rest ...)
+ (others ... field)))))
+
+(define-syntax-rule (mapped-device fields ...)
+ "Build an <mapped-device> record, automatically converting 'target' field
+specifications to 'targets'."
+ (mapped-device-compatibility-helper (fields ...) ()))
+
+(define-deprecated (mapped-device-target md)
+ mapped-device-targets
+ (car (mapped-device-targets md)))
+
(define-record-type* <mapped-device-type> mapped-device-kind
make-mapped-device-kind
mapped-device-kind?
@@ -97,14 +122,14 @@
(shepherd-service-type
'device-mapping
(match-lambda
- (($ <mapped-device> source target
+ (($ <mapped-device> source targets
($ <mapped-device-type> open close))
(shepherd-service
- (provision (list (symbol-append 'device-mapping- (string->symbol target))))
+ (provision (list (symbol-append 'device-mapping- (string->symbol (string-join targets "-")))))
(requirement '(udev))
(documentation "Map a device node using Linux's device mapper.")
- (start #~(lambda () #$(open source target)))
- (stop #~(lambda _ (not #$(close source target))))
+ (start #~(lambda () #$(open source targets)))
+ (stop #~(lambda _ (not #$(close source targets))))
(respawn? #f))))))
(define (device-mapping-service mapped-device)
@@ -162,48 +187,52 @@ option of @command{guix system}.\n")
;;; Common device mappings.
;;;
-(define (open-luks-device source target)
+(define (open-luks-device source targets)
"Return a gexp that maps SOURCE to TARGET as a LUKS device, using
'cryptsetup'."
(with-imported-modules (source-module-closure
'((gnu build file-systems)))
- #~(let ((source #$(if (uuid? source)
- (uuid-bytevector source)
- source)))
- ;; XXX: 'use-modules' should be at the top level.
- (use-modules (rnrs bytevectors) ;bytevector?
- ((gnu build file-systems)
- #:select (find-partition-by-luks-uuid)))
-
- ;; Use 'cryptsetup-static', not 'cryptsetup', to avoid pulling the
- ;; whole world inside the initrd (for when we're in an initrd).
- (zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
- "open" "--type" "luks"
-
- ;; Note: We cannot use the "UUID=source" syntax here
- ;; because 'cryptsetup' implements it by searching the
- ;; udev-populated /dev/disk/by-id directory but udev may
- ;; be unavailable at the time we run this.
- (if (bytevector? source)
- (or (let loop ((tries-left 10))
- (and (positive? tries-left)
- (or (find-partition-by-luks-uuid source)
- ;; If the underlying partition is
- ;; not found, try again after
- ;; waiting a second, up to ten
- ;; times. FIXME: This should be
- ;; dealt with in a more robust way.
- (begin (sleep 1)
- (loop (- tries-left 1))))))
- (error "LUKS partition not found" source))
- source)
-
- #$target)))))
-
-(define (close-luks-device source target)
+ (match targets
+ ((target)
+ #~(let ((source #$(if (uuid? source)
+ (uuid-bytevector source)
+ source)))
+ ;; XXX: 'use-modules' should be at the top level.
+ (use-modules (rnrs bytevectors) ;bytevector?
+ ((gnu build file-systems)
+ #:select (find-partition-by-luks-uuid)))
+
+ ;; Use 'cryptsetup-static', not 'cryptsetup', to avoid pulling the
+ ;; whole world inside the initrd (for when we're in an initrd).
+ (zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
+ "open" "--type" "luks"
+
+ ;; Note: We cannot use the "UUID=source" syntax here
+ ;; because 'cryptsetup' implements it by searching the
+ ;; udev-populated /dev/disk/by-id directory but udev may
+ ;; be unavailable at the time we run this.
+ (if (bytevector? source)
+ (or (let loop ((tries-left 10))
+ (and (positive? tries-left)
+ (or (find-partition-by-luks-uuid source)
+ ;; If the underlying partition is
+ ;; not found, try again after
+ ;; waiting a second, up to ten
+ ;; times. FIXME: This should be
+ ;; dealt with in a more robust way.
+ (begin (sleep 1)
+ (loop (- tries-left 1))))))
+ (error "LUKS partition not found" source))
+ source)
+
+ #$target)))))))
+
+(define (close-luks-device source targets)
"Return a gexp that closes TARGET, a LUKS device."
- #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
- "close" #$target)))
+ (match targets
+ ((target)
+ #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
+ "close" #$target)))))
(define* (check-luks-device md #:key
needed-for-boot?
@@ -235,36 +264,40 @@ option of @command{guix system}.\n")
(close close-luks-device)
(check check-luks-device)))
-(define (open-raid-device sources target)
+(define (open-raid-device sources targets)
"Return a gexp that assembles SOURCES (a list of devices) to the RAID device
TARGET (e.g., \"/dev/md0\"), using 'mdadm'."
- #~(let ((sources '#$sources)
-
- ;; XXX: We're not at the top level here. We could use a
- ;; non-top-level 'use-modules' form but that doesn't work when the
- ;; code is eval'd, like the Shepherd does.
- (every (@ (srfi srfi-1) every))
- (format (@ (ice-9 format) format)))
- (let loop ((attempts 0))
- (unless (every file-exists? sources)
- (when (> attempts 20)
- (error "RAID devices did not show up; bailing out"
- sources))
-
- (format #t "waiting for RAID source devices~{ ~a~}...~%"
- sources)
- (sleep 1)
- (loop (+ 1 attempts))))
-
- ;; Use 'mdadm-static' rather than 'mdadm' to avoid pulling its whole
- ;; closure (80 MiB) in the initrd when a RAID device is needed for boot.
- (zero? (apply system* #$(file-append mdadm-static "/sbin/mdadm")
- "--assemble" #$target sources))))
-
-(define (close-raid-device sources target)
+ (match targets
+ ((target)
+ #~(let ((sources '#$sources)
+
+ ;; XXX: We're not at the top level here. We could use a
+ ;; non-top-level 'use-modules' form but that doesn't work when the
+ ;; code is eval'd, like the Shepherd does.
+ (every (@ (srfi srfi-1) every))
+ (format (@ (ice-9 format) format)))
+ (let loop ((attempts 0))
+ (unless (every file-exists? sources)
+ (when (> attempts 20)
+ (error "RAID devices did not show up; bailing out"
+ sources))
+
+ (format #t "waiting for RAID source devices~{ ~a~}...~%"
+ sources)
+ (sleep 1)
+ (loop (+ 1 attempts))))
+
+ ;; Use 'mdadm-static' rather than 'mdadm' to avoid pulling its whole
+ ;; closure (80 MiB) in the initrd when a RAID device is needed for boot.
+ (zero? (apply system* #$(file-append mdadm-static "/sbin/mdadm")
+ "--assemble" #$target sources))))))
+
+(define (close-raid-device sources targets)
"Return a gexp that stops the RAID device TARGET."
- #~(zero? (system* #$(file-append mdadm-static "/sbin/mdadm")
- "--stop" #$target)))
+ (match targets
+ ((target)
+ #~(zero? (system* #$(file-append mdadm-static "/sbin/mdadm")
+ "--stop" #$target)))))
(define raid-device-mapping
;; The type of RAID mapped devices.
@@ -272,4 +305,24 @@ TARGET (e.g., \"/dev/md0\"), using 'mdadm'."
(open open-raid-device)
(close close-raid-device)))
+(define (open-lvm-device source targets)
+ #~(and
+ (zero? (system* #$(file-append lvm2-static "/sbin/lvm")
+ "vgchange" "--activate" "ay" #$source))
+ ; /dev/mapper nodes are usually created by udev, but udev may be unavailable at the time we run this. So we create them here.
+ (zero? (system* #$(file-append lvm2-static "/sbin/lvm")
+ "vgscan" "--mknodes"))
+ (every file-exists? (map (lambda (file) (string-append "/dev/mapper/" file))
+ '#$targets))))
+
+
+(define (close-lvm-device source targets)
+ #~(zero? (system* #$(file-append lvm2-static "/sbin/lvm")
+ "vgchange" "--activate" "n" #$source)))
+
+(define lvm-device-mapping
+ (mapped-device-kind
+ (open open-lvm-device)
+ (close close-lvm-device)))
+
;;; mapped-devices.scm ends here
diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm
index c8352f4933..f4c4be6e2b 100644
--- a/gnu/system/uuid.scm
+++ b/gnu/system/uuid.scm
@@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Danny Milosavljevic <dannym@scratchpost.org>
-;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2019, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -42,6 +42,7 @@
string->ext2-uuid
string->ext3-uuid
string->ext4-uuid
+ string->bcachefs-uuid
string->btrfs-uuid
string->fat-uuid
string->jfs-uuid
@@ -236,6 +237,7 @@ ISO9660 UUID representation."
(define string->ext2-uuid string->dce-uuid)
(define string->ext3-uuid string->dce-uuid)
(define string->ext4-uuid string->dce-uuid)
+(define string->bcachefs-uuid string->dce-uuid)
(define string->btrfs-uuid string->dce-uuid)
(define string->jfs-uuid string->dce-uuid)
@@ -251,14 +253,14 @@ ISO9660 UUID representation."
(define %uuid-parsers
(vhashq
- ('dce 'ext2 'ext3 'ext4 'btrfs 'jfs 'luks => string->dce-uuid)
+ ('dce 'ext2 'ext3 'ext4 'bcachefs 'btrfs 'jfs 'luks => string->dce-uuid)
('fat32 'fat16 'fat => string->fat-uuid)
('ntfs => string->ntfs-uuid)
('iso9660 => string->iso9660-uuid)))
(define %uuid-printers
(vhashq
- ('dce 'ext2 'ext3 'ext4 'btrfs 'jfs 'luks => dce-uuid->string)
+ ('dce 'ext2 'ext3 'ext4 'bcachefs 'btrfs 'jfs 'luks => dce-uuid->string)
('iso9660 => iso9660-uuid->string)
('fat32 'fat16 'fat => fat-uuid->string)
('ntfs => ntfs-uuid->string)))
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 3a5204e11b..93a79b12d6 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -77,7 +77,6 @@
system-qemu-image/shared-store
system-qemu-image/shared-store-script
- system-disk-image-in-vm
system-docker-image
virtual-machine
@@ -224,6 +223,12 @@ substitutable."
(use-modules (guix build utils)
(gnu build vm))
+ ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded
+ ;; by 'estimated-partition-size' below.
+ (setenv "GUIX_LOCPATH"
+ #+(file-append glibc-utf8-locales "/lib/locale"))
+ (setlocale LC_ALL "en_US.utf8")
+
(let* ((native-inputs
'#+(list qemu (canonical-package coreutils)))
(linux (string-append
@@ -557,77 +562,6 @@ the operating system."
;;; VM and disk images.
;;;
-(define* (system-disk-image-in-vm os
- #:key
- (name "disk-image")
- (file-system-type "ext4")
- (disk-image-size (* 900 (expt 2 20)))
- (volatile? #t)
- (substitutable? #t))
- "Return the derivation of a disk image of DISK-IMAGE-SIZE bytes of the
-system described by OS. Said image can be copied on a USB stick as is. When
-VOLATILE? is true, the root file system is made volatile; this is useful
-to USB sticks meant to be read-only.
-
-SUBSTITUTABLE? determines whether the returned derivation should be marked as
-substitutable."
- (define root-label
- "Guix_image")
-
- (define (root-uuid os)
- ;; UUID of the root file system, computed in a deterministic fashion.
- ;; This is what we use to locate the root file system so it has to be
- ;; different from the user's own file system UUIDs.
- (operating-system-uuid os 'dce))
-
- (define file-systems-to-keep
- (remove (lambda (fs)
- (string=? (file-system-mount-point fs) "/"))
- (operating-system-file-systems os)))
-
- (let* ((os (operating-system (inherit os)
- ;; Since this is meant to be used on real hardware, don't
- ;; install QEMU networking or anything like that. Assume USB
- ;; mass storage devices (usb-storage.ko) are available.
- (initrd (lambda (file-systems . rest)
- (apply (operating-system-initrd os)
- file-systems
- #:volatile-root? volatile?
- rest)))
-
- (bootloader (operating-system-bootloader os))
-
- ;; Force our own root file system. (We need a "/" file system
- ;; to call 'root-uuid'.)
- (file-systems (cons (file-system
- (mount-point "/")
- (device "/dev/placeholder")
- (type file-system-type))
- file-systems-to-keep))))
- (uuid (root-uuid os))
- (os (operating-system
- (inherit os)
- (file-systems (cons (file-system
- (mount-point "/")
- (device uuid)
- (type file-system-type))
- file-systems-to-keep))))
- (bootcfg (operating-system-bootcfg os)))
- (qemu-image #:name name
- #:os os
- #:bootcfg-drv bootcfg
- #:bootloader (bootloader-configuration-bootloader
- (operating-system-bootloader os))
- #:disk-image-size disk-image-size
- #:disk-image-format "raw"
- #:file-system-type file-system-type
- #:file-system-label root-label
- #:file-system-uuid uuid
- #:copy-inputs? #t
- #:inputs `(("system" ,os)
- ("bootcfg" ,bootcfg))
- #:substitutable? substitutable?)))
-
(define* (system-qemu-image os
#:key
(file-system-type "ext4")
@@ -641,7 +575,10 @@ of the GNU system as described by OS."
(let ((target (file-system-mount-point fs))
(source (file-system-device fs)))
(or (string=? target "/")
- (string-prefix? "/dev/" source))))
+ (and (string? source)
+ (string-prefix? "/dev/" source))
+ (uuid? source)
+ (file-system-label? source))))
(operating-system-file-systems os)))
(define root-uuid
@@ -652,7 +589,14 @@ of the GNU system as described by OS."
'dce)))
- (let* ((os (operating-system (inherit os)
+ (let* ((os (operating-system
+ (inherit os)
+
+ ;; As in 'virtualized-operating-system', use BIOS-style GRUB.
+ (bootloader (bootloader-configuration
+ (bootloader grub-bootloader)
+ (target "/dev/vda")))
+
;; Assume we have an initrd with the whole QEMU shebang.
;; Force our own root file system. Refer to it by UUID so that