diff --git a/gnu/system/image.scm b/gnu/system/image.scm index b58de1db14..6201b36334 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -448,63 +448,66 @@ (define (partition->gpt-type partition) (format #f (G_ "unsupported partition type: ~a") file-system))))))))) + (define (image-builder partition) + "A directory, filled by calling the PARTITION initializer +procedure, is first created within the store. Then, an image of this +directory is created using tools such as 'mke2fs' or 'mkdosfs', +depending on the partition file-system type." + (let ((os (image-operating-system image)) + (schema (local-file (search-path %load-path + "guix/store/schema.sql"))) + (graph (match inputs + (((names . _) ...) + names))) + (type (partition-file-system partition))) + (with-imported-modules* + (let ((initializer (or #$(partition-initializer partition) + initialize-root-partition)) + (inputs '#+(cond + ((string-prefix? "ext" type) + (list e2fsprogs fakeroot)) + ((or (string=? type "vfat") + (string-prefix? "fat" type)) + (list dosfstools fakeroot mtools)) + (else + '()))) + (image-root (string-append (getcwd) "/tmp-root")) + (copy-closures? (not #$(image-shared-store? image)))) + (sql-schema #$schema) + + (set-path-environment-variable "PATH" '("bin" "sbin") inputs) + + ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be + ;; decoded. + (setenv "GUIX_LOCPATH" + #+(file-append (libc-utf8-locales-for-target + (%current-system)) + "/lib/locale")) + (setlocale LC_ALL "en_US.utf8") + + (initializer image-root + #:references-graphs '#$graph + #:deduplicate? #f + #:copy-closures? copy-closures? + #:system-directory #$os) + ;; There's no point installing a bootloader if we do not + ;; populate the store. + (when copy-closures? + ;; Root-offset isn't necessary: we override 'root. + #$(bootloader-configurations->gexp + bootloader-config bootmeta + #:overrides (targets partition))) + (make-partition-image #$(partition->gexp partition) + #$output + image-root))))) + (define (partition-image partition) - ;; Return as a file-like object, an image of the given PARTITION. A - ;; directory, filled by calling the PARTITION initializer procedure, is - ;; first created within the store. Then, an image of this directory is - ;; created using tools such as 'mke2fs' or 'mkdosfs', depending on the - ;; partition file-system type. - (let* ((os (image-operating-system image)) - (schema (local-file (search-path %load-path - "guix/store/schema.sql"))) - (graph (match inputs - (((names . _) ...) - names))) - (type (partition-file-system partition)) - (image-builder - (with-imported-modules* - (let ((initializer (or #$(partition-initializer partition) - initialize-root-partition)) - (inputs '#+(cond - ((string-prefix? "ext" type) - (list e2fsprogs fakeroot)) - ((or (string=? type "vfat") - (string-prefix? "fat" type)) - (list dosfstools fakeroot mtools)) - (else - '()))) - (image-root (string-append (getcwd) "/tmp-root")) - (copy-closures? (not #$(image-shared-store? image)))) - (sql-schema #$schema) - - (set-path-environment-variable "PATH" '("bin" "sbin") inputs) - - ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be - ;; decoded. - (setenv "GUIX_LOCPATH" - #+(file-append (libc-utf8-locales-for-target - (%current-system)) - "/lib/locale")) - (setlocale LC_ALL "en_US.utf8") - - (initializer image-root - #:references-graphs '#$graph - #:deduplicate? #f - #:copy-closures? copy-closures? - #:system-directory #$os) - ;; no point installing a bootloader if we don't populate store - (when copy-closures? - ;; root-offset isn't necessary - we override 'root - #$(bootloader-configurations->gexp bootloader-config bootmeta - #:overrides (targets partition))) - (make-partition-image #$(partition->gexp partition) - #$output - image-root))))) - (computed-file "partition.img" image-builder - ;; Allow offloading so that this I/O-intensive process - ;; doesn't run on the build farm's head node. - #:local-build? #f - #:options `(#:references-graphs ,inputs)))) + "Return as a file-like object, an image of the given PARTITION." + (computed-file "partition.img" (image-builder partition) + ;; Allow offloading so that this I/O-intensive process + ;; doesn't run on the build farm's head node. + #:local-build? #f + #:options `(#:references-graphs ,inputs))) (define (gpt-image? image) (eq? 'gpt (image-partition-table-type image)))