From a502fa70b0230d3f91ddf05410f24a1f4fcad521 Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Sat, 29 Aug 2020 15:34:56 +0200 Subject: [PATCH 1/3] 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. --- doc/guix.texi | 4 +++- guix/scripts/system.scm | 27 ++++++++++++++++++++++----- 2 files changed, 25 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/guix/scripts/system.scm b/guix/scripts/system.scm index f6d20382b6..33f4c8e4e8 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2018 Ricardo Wurmus ;;; Copyright © 2019 Christopher Baines ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen +;;; Copyright © 2020 Julien Lepiller ;;; ;;; This file is part of GNU Guix. ;;; @@ -67,7 +68,7 @@ #:use-module (gnu services) #:use-module (gnu services shepherd) #:use-module (gnu services herd) - #:use-module (srfi srfi-1) + #:use-module ((srfi srfi-1) #:hide (partition)) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) @@ -662,7 +663,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) @@ -688,7 +689,14 @@ checking this by themselves in their 'check' procedure." (image (inherit base-image) (size image-size) - (operating-system os))))) + (operating-system os) + (partitions (match (image-partitions base-image) + ((boot others ...) + (cons + (partition + (inherit boot) + (label (or label (partition-label boot)))) + others)))))))) ((docker-image) (system-docker-image os #:shared-network? container-shared-network?)))) @@ -741,7 +749,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)) @@ -795,6 +803,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? @@ -942,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_ " @@ -1008,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))) @@ -1065,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." @@ -1119,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))) @@ -1169,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))))) -- 2.28.0