diff options
| -rw-r--r-- | doc/guix.texi | 4 | ||||
| -rw-r--r-- | gnu/system/image.scm | 17 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 18 |
3 files changed, 33 insertions, 6 deletions
diff --git a/doc/guix.texi b/doc/guix.texi index 6206a93857..56b1cd8976 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -28836,7 +28836,9 @@ the @option{--image-size} option is ignored in the case of @code{docker-image}. You can specify the root file system type by using the -@option{--file-system-type} option. It defaults to @code{ext4}. +@option{--file-system-type} option. It defaults to @code{ext4}. When its +value is @code{iso9660}, the @option{--label} option can be used to specify +a volume ID with @code{disk-image}. When using @code{vm-image}, the returned image is in qcow2 format, which the QEMU emulator can efficiently use. @xref{Running Guix in a VM}, diff --git a/gnu/system/image.scm b/gnu/system/image.scm index c1a718d607..733f2bfa8d 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -63,7 +63,8 @@ iso9660-image find-image - system-image)) + system-image + image-with-label)) ;;; @@ -407,6 +408,20 @@ used in the image. " #:references-graphs ,inputs #:substitutable? ,substitutable?)))) +(define (image-with-label base-image label) + "The volume ID of an ISO is the label of the first partition. This procedure +returns an image record where the first partition's label is set to <label>." + (image + (inherit base-image) + (partitions + (match (image-partitions base-image) + ((boot others ...) + (cons + (partition + (inherit boot) + (label label)) + others)))))) + ;; ;; Image creation. diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 3222a53c8f..b75b0e5b60 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2019 Christopher Baines <mail@cbaines.net> ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> +;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu> ;;; ;;; This file is part of GNU Guix. ;;; @@ -667,7 +668,7 @@ checking this by themselves in their 'check' procedure." (define* (system-derivation-for-action os base-image action #:key image-size file-system-type full-boot? container-shared-network? - mappings) + mappings label) "Return as a monadic value the derivation for OS according to ACTION." (case action ((build init reconfigure) @@ -691,7 +692,7 @@ checking this by themselves in their 'check' procedure." (lower-object (system-image (image - (inherit base-image) + (inherit (if label (image-with-label base-image label) base-image)) (size image-size) (operating-system os))))) ((docker-image) @@ -746,7 +747,7 @@ and TARGET arguments." install-bootloader? dry-run? derivations-only? use-substitutes? bootloader-target target - image-size file-system-type full-boot? + image-size file-system-type full-boot? label container-shared-network? (mappings '()) (gc-root #f)) @@ -800,6 +801,7 @@ static checks." ((target* (current-target-system)) (image -> (find-image file-system-type target*)) (sys (system-derivation-for-action os image action + #:label label #:file-system-type file-system-type #:image-size image-size #:full-boot? full-boot? @@ -950,6 +952,8 @@ Some ACTIONS support additional ARGS.\n")) (display (G_ " --no-bootloader for 'init', do not install a bootloader")) (display (G_ " + --label=LABEL for 'disk-image', label disk image with LABEL")) + (display (G_ " --save-provenance save provenance information")) (display (G_ " --share=SPEC for 'vm', share host file system according to SPEC")) @@ -1015,6 +1019,9 @@ Some ACTIONS support additional ARGS.\n")) (option '("no-bootloader" "no-grub") #f #f (lambda (opt name arg result) (alist-cons 'install-bootloader? #f result))) + (option '("label") #t #f + (lambda (opt name arg result) + (alist-cons 'label arg result))) (option '("full-boot") #f #f (lambda (opt name arg result) (alist-cons 'full-boot? #t result))) @@ -1072,7 +1079,8 @@ Some ACTIONS support additional ARGS.\n")) (validate-reconfigure . ,ensure-forward-reconfigure) (file-system-type . "ext4") (image-size . guess) - (install-bootloader? . #t))) + (install-bootloader? . #t) + (label . #f))) (define (verbosity-level opts) "Return the verbosity level based on OPTS, the alist of parsed options." @@ -1126,6 +1134,7 @@ resulting from command-line parsing." (dry? (assoc-ref opts 'dry-run?)) (bootloader? (assoc-ref opts 'install-bootloader?)) + (label (assoc-ref opts 'label)) (target-file (match args ((first second) second) (_ #f))) @@ -1176,6 +1185,7 @@ resulting from command-line parsing." (_ #f)) opts) #:install-bootloader? bootloader? + #:label label #:target target-file #:bootloader-target bootloader-target #:gc-root (assoc-ref opts 'gc-root))))) |