summaryrefslogtreecommitdiff
path: root/gnu/system/vm.scm
diff options
context:
space:
mode:
authorMarius Bakke <mbakke@fastmail.com>2020-05-05 20:43:21 +0200
committerMarius Bakke <mbakke@fastmail.com>2020-05-05 20:43:21 +0200
commit87a40d7203a813921b3ef0805c2b46c0026d6c31 (patch)
treecebad70c1df30969005c18c4d9faa39d7d80cbf6 /gnu/system/vm.scm
parentba151b7e1a9cc0baf932b5c5e0c916e54d2e27f4 (diff)
parent751d1f01e4f0607d41e4c859d944753b18466652 (diff)
Merge branch 'master' into core-updates
Diffstat (limited to 'gnu/system/vm.scm')
-rw-r--r--gnu/system/vm.scm216
1 files changed, 25 insertions, 191 deletions
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 1d5ee39497..4ea82cfd50 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -77,7 +77,7 @@
system-qemu-image/shared-store
system-qemu-image/shared-store-script
- system-disk-image
+ system-disk-image-in-vm
system-docker-image
virtual-machine
@@ -269,95 +269,6 @@ substitutable."
(eq? (service-kind service) guix-service-type))
(operating-system-services os)))))
-(define* (iso9660-image #:key
- (name "iso9660-image")
- file-system-label
- file-system-uuid
- (system (%current-system))
- (target (%current-target-system))
- (qemu qemu-minimal)
- os
- bootcfg-drv
- bootloader
- (register-closures? (has-guix-service-type? os))
- (inputs '())
- (grub-mkrescue-environment '())
- (substitutable? #t))
- "Return a bootable, stand-alone iso9660 image.
-
-INPUTS is a list of inputs (as for packages)."
- (define schema
- (and register-closures?
- (local-file (search-path %load-path
- "guix/store/schema.sql"))))
-
- (expression->derivation-in-linux-vm
- name
- (with-extensions gcrypt-sqlite3&co
- (with-imported-modules `(,@(source-module-closure '((gnu build vm)
- (guix store database)
- (guix build utils))
- #:select? not-config?)
- ((guix config) => ,(make-config.scm)))
- #~(begin
- (use-modules (gnu build vm)
- (guix store database)
- (guix build utils))
-
- (sql-schema #$schema)
-
- ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
- (setenv "GUIX_LOCPATH"
- #+(file-append glibc-utf8-locales "/lib/locale"))
- (setlocale LC_ALL "en_US.utf8")
-
- (let ((inputs
- '#$(append (list parted e2fsprogs dosfstools xorriso)
- (map canonical-package
- (list sed grep coreutils findutils gawk))))
-
-
- (graphs '#$(match inputs
- (((names . _) ...)
- names)))
- ;; This variable is unused but allows us to add INPUTS-TO-COPY
- ;; as inputs.
- (to-register
- '#$(map (match-lambda
- ((name thing) thing)
- ((name thing output) `(,thing ,output)))
- inputs)))
-
- (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
- (make-iso9660-image #$xorriso
- '#$grub-mkrescue-environment
- #$(bootloader-package bootloader)
- #$bootcfg-drv
- #$os
- "/xchg/guixsd.iso"
- #:register-closures? #$register-closures?
- #:closures graphs
- #:volume-id #$file-system-label
- #:volume-uuid #$(and=> file-system-uuid
- uuid-bytevector))))))
- #:system system
- #:target target
-
- ;; Keep a local file system for /tmp so that we can populate it directly as
- ;; root and have files owned by root. See <https://bugs.gnu.org/31752>.
- #:file-systems (remove (lambda (file-system)
- (string=? (file-system-mount-point file-system)
- "/tmp"))
- %linux-vm-file-systems)
-
- #:make-disk-image? #f
- #:single-file-output? #t
- #:references-graphs inputs
- #:substitutable? substitutable?
-
- ;; Xorriso seems to be quite memory-hungry, so increase the VM's RAM size.
- #:memory-size 512))
-
(define* (qemu-image #:key
(name "qemu-image")
(system (%current-system))
@@ -624,62 +535,13 @@ system."
;;; 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."
- ;; Note: For this to be deterministic, we must not hash things that contains
- ;; (directly or indirectly) procedures, for example. That rules out
- ;; anything that contains gexps, thunk or delayed record fields, etc.
-
- (define service-name
- (compose service-type-name service-kind))
-
- (define (file-system-digest fs)
- ;; Return a hashable digest that does not contain 'dependencies' since
- ;; this field can contain procedures.
- (let ((device (file-system-device fs)))
- (list (file-system-mount-point fs)
- (file-system-type fs)
- (file-system-device->string device)
- (file-system-options fs))))
-
- (if (eq? type 'iso9660)
- (let ((pad (compose (cut string-pad <> 2 #\0)
- number->string))
- (h (hash (map service-name (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 (map file-system-digest
- (operating-system-file-systems os))
- 100))))
- 'iso9660))
- (bytevector->uuid
- (uint-list->bytevector
- (list (hash (map file-system-digest
- (operating-system-file-systems os))
- (- (expt 2 32) 1))
- (hash (operating-system-host-name os)
- (- (expt 2 32) 1))
- (hash (map service-name (operating-system-services os))
- (- (expt 2 32) 1))
- (hash (map file-system-digest (operating-system-file-systems os))
- (- (expt 2 32) 1)))
- (endianness little)
- 4)
- type)))
-
-(define* (system-disk-image os
- #:key
- (name "disk-image")
- (file-system-type "ext4")
- (disk-image-size (* 900 (expt 2 20)))
- (volatile? #t)
- (substitutable? #t))
+(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
@@ -687,25 +549,14 @@ to USB sticks meant to be read-only.
SUBSTITUTABLE? determines whether the returned derivation should be marked as
substitutable."
- (define normalize-label
- ;; ISO labels are all-caps (case-insensitive), but since
- ;; 'find-partition-by-label' is case-sensitive, make it all-caps here.
- (if (string=? "iso9660" file-system-type)
- string-upcase
- identity))
-
(define root-label
- ;; Volume name of the root file system.
- (normalize-label "Guix_image"))
+ "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
- (if (string=? file-system-type "iso9660")
- 'iso9660
- 'dce)))
+ (operating-system-uuid os 'dce))
(define file-systems-to-keep
(remove (lambda (fs)
@@ -722,11 +573,7 @@ substitutable."
#:volatile-root? volatile?
rest)))
- (bootloader (if (string=? "iso9660" file-system-type)
- (bootloader-configuration
- (inherit (operating-system-bootloader os))
- (bootloader grub-mkrescue-bootloader))
- (operating-system-bootloader os)))
+ (bootloader (operating-system-bootloader os))
;; Force our own root file system. (We need a "/" file system
;; to call 'root-uuid'.)
@@ -744,33 +591,20 @@ substitutable."
(type file-system-type))
file-systems-to-keep))))
(bootcfg (operating-system-bootcfg os)))
- (if (string=? "iso9660" file-system-type)
- (iso9660-image #:name name
- #:file-system-label root-label
- #:file-system-uuid uuid
- #:os os
- #:bootcfg-drv bootcfg
- #:bootloader (bootloader-configuration-bootloader
- (operating-system-bootloader os))
- #:inputs `(("system" ,os)
- ("bootcfg" ,bootcfg))
- #:grub-mkrescue-environment
- '(("MKRESCUE_SED_MODE" . "mbr_hfs"))
- #:substitutable? substitutable?)
- (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?))))
+ (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