aboutsummaryrefslogtreecommitdiff
path: root/gnu/system/vm.scm
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/system/vm.scm')
-rw-r--r--gnu/system/vm.scm79
1 files changed, 66 insertions, 13 deletions
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 4494af0031..78143e4f7a 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -57,9 +57,11 @@
#:use-module (gnu system file-systems)
#:use-module (gnu system)
#:use-module (gnu services)
+ #:use-module (gnu system uuid)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
+ #:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
#:export (expression->derivation-in-linux-vm
@@ -192,6 +194,7 @@ made available under the /xchg CIFS share."
os-drv
bootcfg-drv
bootloader
+ register-closures?
(inputs '()))
"Return a bootable, stand-alone iso9660 image.
@@ -207,8 +210,13 @@ INPUTS is a list of inputs (as for packages)."
(let ((inputs
'#$(append (list qemu parted e2fsprogs dosfstools xorriso)
(map canonical-package
- (list sed grep coreutils findutils gawk))))
+ (list sed grep coreutils findutils gawk))
+ (if register-closures? (list guix) '())))
+
+ (graphs '#$(match inputs
+ (((names . _) ...)
+ names)))
;; This variable is unused but allows us to add INPUTS-TO-COPY
;; as inputs.
(to-register
@@ -222,8 +230,11 @@ INPUTS is a list of inputs (as for packages)."
#$bootcfg-drv
#$os-drv
"/xchg/guixsd.iso"
+ #:register-closures? #$register-closures?
+ #:closures graphs
#:volume-id #$file-system-label
- #:volume-uuid #$file-system-uuid)
+ #:volume-uuid #$(and=> file-system-uuid
+ uuid-bytevector))
(reboot))))
#:system system
#:make-disk-image? #f
@@ -238,6 +249,7 @@ INPUTS is a list of inputs (as for packages)."
(disk-image-format "qcow2")
(file-system-type "ext4")
file-system-label
+ file-system-uuid
os-drv
bootcfg-drv
bootloader
@@ -247,7 +259,10 @@ INPUTS is a list of inputs (as for packages)."
"Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.
Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
-partition. The returned image is a full disk image that runs OS-DERIVATION,
+partition; likewise FILE-SYSTEM-UUID, if true, specifies the UUID of the root
+partition (a UUID object).
+
+The returned image is a full disk image that runs OS-DERIVATION,
with a GRUB installation that uses GRUB-CONFIGURATION as its configuration
file (GRUB-CONFIGURATION must be the name of a file in the VM.)
@@ -297,6 +312,8 @@ the image."
(partitions (list (partition
(size root-size)
(label #$file-system-label)
+ (uuid #$(and=> file-system-uuid
+ uuid-bytevector))
(file-system #$file-system-type)
(flags '(boot))
(initializer initialize))
@@ -334,6 +351,35 @@ the image."
;;; VM and disk images.
;;;
+(define* (operating-system-uuid os #:optional (type 'dce))
+ "Compute UUID object with a deterministic \"UUID\" for OS, of the given
+TYPE (one of 'iso9660 or 'dce). Return a UUID object."
+ (if (eq? type 'iso9660)
+ (let ((pad (compose (cut string-pad <> 2 #\0)
+ number->string))
+ (h (hash (operating-system-services os) 3600)))
+ (bytevector->uuid
+ (string->iso9660-uuid
+ (string-append "1970-01-01-"
+ (pad (hash (operating-system-host-name os) 24)) "-"
+ (pad (quotient h 60)) "-"
+ (pad (modulo h 60)) "-"
+ (pad (hash (operating-system-file-systems os) 100))))
+ 'iso9660))
+ (bytevector->uuid
+ (uint-list->bytevector
+ (list (hash file-system-type
+ (expt 2 32))
+ (hash (operating-system-host-name os)
+ (expt 2 32))
+ (hash (operating-system-services os)
+ (expt 2 32))
+ (hash (operating-system-file-systems os)
+ (expt 2 32)))
+ (endianness little)
+ 4)
+ type)))
+
(define* (system-disk-image os
#:key
(name "disk-image")
@@ -350,12 +396,20 @@ to USB sticks meant to be read-only."
(if (string=? "iso9660" file-system-type)
string-upcase
identity))
+
(define root-label
- ;; 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.)
+ ;; Volume name of the root file system.
(normalize-label "GuixSD_image"))
+ (define root-uuid
+ ;; 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
+ (if (string=? file-system-type "iso9660")
+ 'iso9660
+ 'dce)))
+
(define file-systems-to-keep
(remove (lambda (fs)
(string=? (file-system-mount-point fs) "/"))
@@ -379,8 +433,8 @@ to USB sticks meant to be read-only."
;; Force our own root file system.
(file-systems (cons (file-system
(mount-point "/")
- (device root-label)
- (title 'label)
+ (device root-uuid)
+ (title 'uuid)
(type file-system-type))
file-systems-to-keep)))))
@@ -389,8 +443,9 @@ to USB sticks meant to be read-only."
(if (string=? "iso9660" file-system-type)
(iso9660-image #:name name
#:file-system-label root-label
- #:file-system-uuid #f
+ #:file-system-uuid root-uuid
#:os-drv os-drv
+ #:register-closures? #t
#:bootcfg-drv bootcfg
#:bootloader (bootloader-configuration-bootloader
(operating-system-bootloader os))
@@ -403,11 +458,9 @@ to USB sticks meant to be read-only."
(operating-system-bootloader os))
#:disk-image-size disk-image-size
#:disk-image-format "raw"
- #:file-system-type (if (string=? "iso9660"
- file-system-type)
- "ext4"
- file-system-type)
+ #:file-system-type file-system-type
#:file-system-label root-label
+ #:file-system-uuid root-uuid
#:copy-inputs? #t
#:register-closures? #t
#:inputs `(("system" ,os-drv)