This is an automated email from the git hooks/post-receive script. mothacehe pushed a commit to branch wip-disk-image in repository guix.
The following commit(s) were added to refs/heads/wip-disk-image by this push: new eeab1a4 image: Fix label and uuid handling. eeab1a4 is described below commit eeab1a4aece8636beb2e4c4373ab4915be42e3d9 Author: Mathieu Othacehe <m.othac...@gmail.com> AuthorDate: Sun Apr 26 19:42:00 2020 +0200 image: Fix label and uuid handling. --- gnu/build/disk-image.scm | 8 ++-- gnu/image.scm | 1 + gnu/system/image.scm | 109 +++++++++++++++++++++++++++-------------------- 3 files changed, 69 insertions(+), 49 deletions(-) diff --git a/gnu/build/disk-image.scm b/gnu/build/disk-image.scm index 0dcc4a8..26653aa 100644 --- a/gnu/build/disk-image.scm +++ b/gnu/build/disk-image.scm @@ -40,10 +40,11 @@ (define (sexp->partition sexp) (match sexp - ((size file-system label) + ((size file-system label uuid) (partition (size size) (file-system file-system) - (label label))))) + (label label) + (uuid uuid))))) (define (size-in-kib size) (number->string @@ -56,9 +57,10 @@ #:key (owner 0)) (let ((size (partition-size partition)) (label (partition-label partition)) + (uuid (partition-uuid partition)) (options "lazy_itable_init=1,lazy_journal_init=1")) (invoke "mke2fs" "-t" "ext4" "-d" root - "-L" label + "-L" label "-U" (uuid->string uuid) "-E" (format #f "root_owner=~a:~a,~a" owner owner options) target diff --git a/gnu/image.scm b/gnu/image.scm index 040546e..fdada40 100644 --- a/gnu/image.scm +++ b/gnu/image.scm @@ -25,6 +25,7 @@ partition-size partition-file-system partition-label + partition-uuid partition-flags partition-initializer diff --git a/gnu/system/image.scm b/gnu/system/image.scm index 467506b..ca63487 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -41,7 +41,8 @@ #:autoload (gnu packages gnupg) (guile-gcrypt) #:use-module (gnu packages linux) #:use-module (gnu packages mtools) - #:use-module ((srfi srfi-1) #:select (append-map remove find)) + #:use-module ((srfi srfi-1) #:prefix scm:) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) @@ -84,20 +85,18 @@ (define iso9660-image (image - (format 'iso9660))) + (format 'iso9660) + (partitions + (list (partition + (size 'guess) + (label "GUIX_IMAGE") + (flags '(boot))))))) ;; ;; Helpers. ;; -(define (root-label image) - (let ((label "Guix_image") - (format (image-format image))) - (if (eq? format 'iso9660) - (string-upcase label) - label))) - (define (root-uuid image) ;; 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 @@ -119,16 +118,19 @@ (define (partition->gexp partition) #~'(#$@(list (partition-size partition)) #$(partition-file-system partition) - #$(partition-label partition))) + #$(partition-label partition) + #$(and=> (partition-uuid partition) + uuid-bytevector))) (define gcrypt-sqlite3&co ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs. - (append-map (lambda (package) - (cons package - (match (package-transitive-propagated-inputs package) - (((labels packages) ...) - packages)))) - (list guile-gcrypt guile-sqlite3))) + (scm:append-map + (lambda (package) + (cons package + (match (package-transitive-propagated-inputs package) + (((labels packages) ...) + packages)))) + (list guile-gcrypt guile-sqlite3))) (define-syntax-rule (with-imported-modules* exp ...) (with-extensions gcrypt-sqlite3&co @@ -153,8 +155,6 @@ (define* (system-disk-image image #:key (name "disk-image") - label - uuid bootcfg bootloader register-closures? @@ -261,9 +261,9 @@ image ~a { (define (has-guix-service-type? os) "Return true if OS contains a service of the type GUIX-SERVICE-TYPE." - (not (not (find (lambda (service) - (eq? (service-kind service) guix-service-type)) - (operating-system-services os))))) + (not (not (scm:find (lambda (service) + (eq? (service-kind service) guix-service-type)) + (operating-system-services os))))) (define* (system-iso9660-image image #:key @@ -276,6 +276,16 @@ image ~a { (inputs '()) (grub-mkrescue-environment '()) (substitutable? #t)) + (define root-label + (match (image-partitions image) + ((partition) + (partition-label partition)))) + + (define root-uuid + (match (image-partitions image) + ((partition) + (uuid-bytevector (partition-uuid partition))))) + (let* ((os (image-operating-system image)) (bootloader (bootloader-package bootloader)) (schema (local-file (search-path %load-path @@ -314,9 +324,8 @@ image ~a { #:references-graphs '#$graph #:register-closures? #$register-closures? #:compression? #f - #:volume-id #$label - #:volume-uuid #$(and=> uuid - uuid-bytevector)))))) + #:volume-id #$root-label + #:volume-uuid #$root-uuid))))) (gexp->derivation name builder #:references-graphs inputs))) @@ -325,22 +334,33 @@ image ~a { ;; Image creation. ;; -(define (image->root-file-system image) - (define (find-root-partition) - (let ((partitions (image-partitions image))) - (find (lambda (partition) - (member 'boot (partition-flags partition))) - partitions))) +(define (root-partition? partition) + (member 'boot (partition-flags partition))) +(define (find-root-partition image) + (scm:find root-partition? (image-partitions image))) + +(define (image->root-file-system image) (let ((format (image-format image))) (if (eq? format 'iso9660) "iso9660" - (partition-file-system (find-root-partition))))) - -(define-syntax-rule (image-with-os base-image os) - (image - (inherit base-image) - (operating-system os))) + (partition-file-system (find-root-partition image))))) + +(define* (image-with-os base-image os + #:key uuid) + (let*-values (((partitions) (image-partitions base-image)) + ((root-partition other-partitions) + (scm:partition root-partition? partitions))) + (image + (inherit base-image) + (operating-system os) + (partitions + (if uuid + (cons (partition + (inherit (car root-partition)) + (uuid uuid)) + other-partitions) + partitions))))) (define* (system-image image #:key @@ -348,9 +368,10 @@ image ~a { (let* ((image-os (image-operating-system image)) (format (image-format image)) (file-systems-to-keep - (remove (lambda (fs) - (string=? (file-system-mount-point fs) "/")) - (operating-system-file-systems image-os))) + (scm:remove + (lambda (fs) + (string=? (file-system-mount-point fs) "/")) + (operating-system-file-systems image-os))) (root-file-system-type (image->root-file-system image)) (os (operating-system (inherit image-os) @@ -363,7 +384,7 @@ image ~a { (bootloader-configuration (inherit (operating-system-bootloader image-os)) - (bootloader grub-mkrescue-bootloader)) + (bootloader grub-mkrescue-bootloader)) (operating-system-bootloader image-os))) (file-systems (cons (file-system (mount-point "/") @@ -371,7 +392,6 @@ image ~a { (type root-file-system-type)) file-systems-to-keep)))) (uuid (root-uuid image)) - (label (root-label image)) (os (operating-system (inherit os) (file-systems (cons (file-system @@ -379,7 +399,8 @@ image ~a { (device uuid) (type root-file-system-type)) file-systems-to-keep)))) - (image* (image-with-os image os)) + (image* (image-with-os image os + #:uuid uuid)) (register-closures? (has-guix-service-type? os)) (bootcfg (operating-system-bootcfg os)) (bootloader (bootloader-configuration-bootloader @@ -387,8 +408,6 @@ image ~a { (case (image-format image) ((disk-image) (system-disk-image image* - #:label label - #:uuid uuid #:bootcfg bootcfg #:bootloader bootloader #:register-closures? register-closures? @@ -397,8 +416,6 @@ image ~a { #:substitutable? substitutable?)) ((iso9660) (system-iso9660-image image* - #:label label - #:uuid uuid #:bootcfg bootcfg #:bootloader bootloader #:register-closures? register-closures?