guix: system: Add `--label' option.
* guix/scripts/system.scm (%options): Add `--label'. (system-derivation-for-action): Take a #:label key to set volume ID. (perform-action): Take a #:label key. (%default-options): Add default label value. (process-action): Pass label value from command-line to perform-action. * gnu/system/image.scm (image-with-label): New procedure.master
Julien Lepiller
parent
7e90e28a15
commit
036f23f053
|
|
@ -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},
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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?
|
||||
|
|
@ -949,6 +951,8 @@ Some ACTIONS support additional ARGS.\n"))
|
|||
--image-size=SIZE for 'vm-image', produce an image of SIZE"))
|
||||
(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_ "
|
||||
|
|
@ -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)))))
|
||||
|
|
|
|||
Reference in New Issue