[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
03/03: system: image: Factorize image creation.
|
From: |
guix-commits |
|
Subject: |
03/03: system: image: Factorize image creation. |
|
Date: |
Fri, 24 Apr 2020 13:16:54 -0400 (EDT) |
mothacehe pushed a commit to branch wip-disk-image
in repository guix.
commit eb6bd610def3497cd6173dad718930bc9582687b
Author: Mathieu Othacehe <address@hidden>
AuthorDate: Fri Apr 24 19:16:25 2020 +0200
system: image: Factorize image creation.
---
gnu/system.scm | 50 ++++++
gnu/system/image.scm | 430 ++++++++++++++++++++++++++++-----------------------
gnu/system/vm.scm | 49 ------
3 files changed, 283 insertions(+), 246 deletions(-)
diff --git a/gnu/system.scm b/gnu/system.scm
index d79ea23..3affa57 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -117,6 +117,7 @@
operating-system-etc-directory
operating-system-locale-directory
operating-system-boot-script
+ operating-system-uuid
system-linux-image-file-name
operating-system-with-gc-roots
@@ -944,6 +945,55 @@ we're running in the final root."
#:mapped-devices mapped-devices
#:keyboard-layout (operating-system-keyboard-layout os)))
+(define* (operating-system-uuid os #:optional (type 'dce))
+ "Compute UUID object with a deterministic \"UUID\" for OS, of the given
+TYPE (one of 'iso9660 or 'dce). Return a UUID object."
+ ;; Note: For this to be deterministic, we must not hash things that contains
+ ;; (directly or indirectly) procedures, for example. That rules out
+ ;; anything that contains gexps, thunk or delayed record fields, etc.
+
+ (define service-name
+ (compose service-type-name service-kind))
+
+ (define (file-system-digest fs)
+ ;; Return a hashable digest that does not contain 'dependencies' since
+ ;; this field can contain procedures.
+ (let ((device (file-system-device fs)))
+ (list (file-system-mount-point fs)
+ (file-system-type fs)
+ (file-system-device->string device)
+ (file-system-options fs))))
+
+ (if (eq? type 'iso9660)
+ (let ((pad (compose (cut string-pad <> 2 #\0)
+ number->string))
+ (h (hash (map service-name (operating-system-services os))
+ 3600)))
+ (bytevector->uuid
+ (string->iso9660-uuid
+ (string-append "1970-01-01-"
+ (pad (hash (operating-system-host-name os) 24)) "-"
+ (pad (quotient h 60)) "-"
+ (pad (modulo h 60)) "-"
+ (pad (hash (map file-system-digest
+ (operating-system-file-systems os))
+ 100))))
+ 'iso9660))
+ (bytevector->uuid
+ (uint-list->bytevector
+ (list (hash (map file-system-digest
+ (operating-system-file-systems os))
+ (- (expt 2 32) 1))
+ (hash (operating-system-host-name os)
+ (- (expt 2 32) 1))
+ (hash (map service-name (operating-system-services os))
+ (- (expt 2 32) 1))
+ (hash (map file-system-digest (operating-system-file-systems os))
+ (- (expt 2 32) 1)))
+ (endianness little)
+ 4)
+ type)))
+
(define (locale-name->definition* name)
"Variant of 'locale-name->definition' that raises an error upon failure."
(match (locale-name->definition name)
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index 9554239..64b5ce2 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -26,6 +26,7 @@
#:use-module (gnu bootloader grub)
#:use-module (gnu image)
#:use-module (gnu services)
+ #:use-module (gnu services base)
#:use-module (gnu system)
#:use-module (gnu system file-systems)
#:use-module (gnu system uuid)
@@ -40,7 +41,7 @@
#: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))
+ #:use-module ((srfi srfi-1) #:select (append-map remove find))
#:use-module (srfi srfi-26)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
@@ -50,8 +51,6 @@
efi-disk-image
iso9660-image
- system-iso9660-image
- system-disk-image
system-image))
@@ -87,63 +86,27 @@
(image
(format 'iso9660)))
-(define root-iso-label
- "GUIX_IMAGE")
-
-(define* (operating-system-uuid os #:optional (type 'dce))
- "Compute UUID object with a deterministic \"UUID\" for OS, of the given
-TYPE (one of 'iso9660 or 'dce). Return a UUID object."
- ;; Note: For this to be deterministic, we must not hash things that contains
- ;; (directly or indirectly) procedures, for example. That rules out
- ;; anything that contains gexps, thunk or delayed record fields, etc.
-
- (define service-name
- (compose service-type-name service-kind))
-
- (define (file-system-digest fs)
- ;; Return a hashable digest that does not contain 'dependencies' since
- ;; this field can contain procedures.
- (let ((device (file-system-device fs)))
- (list (file-system-mount-point fs)
- (file-system-type fs)
- (file-system-device->string device)
- (file-system-options fs))))
-
- (if (eq? type 'iso9660)
- (let ((pad (compose (cut string-pad <> 2 #\0)
- number->string))
- (h (hash (map service-name (operating-system-services os))
- 3600)))
- (bytevector->uuid
- (string->iso9660-uuid
- (string-append "1970-01-01-"
- (pad (hash (operating-system-host-name os) 24)) "-"
- (pad (quotient h 60)) "-"
- (pad (modulo h 60)) "-"
- (pad (hash (map file-system-digest
- (operating-system-file-systems os))
- 100))))
- 'iso9660))
- (bytevector->uuid
- (uint-list->bytevector
- (list (hash (map file-system-digest
- (operating-system-file-systems os))
- (- (expt 2 32) 1))
- (hash (operating-system-host-name os)
- (- (expt 2 32) 1))
- (hash (map service-name (operating-system-services os))
- (- (expt 2 32) 1))
- (hash (map file-system-digest (operating-system-file-systems os))
- (- (expt 2 32) 1)))
- (endianness little)
- 4)
- type)))
-
-(define (root-iso-uuid os)
+
+;;
+;; 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
;; different from the user's own file system UUIDs.
- (operating-system-uuid os 'iso9660))
+ (let ((os (image-operating-system image))
+ (type (if (eq? (image-format image) 'iso9660)
+ 'iso9660
+ 'dce)))
+ (operating-system-uuid os type)))
(define not-config?
;; Select (guix …) and (gnu …) modules, except (guix config).
@@ -182,130 +145,136 @@ TYPE (one of 'iso9660 or 'dce). Return a UUID object."
(guix build utils))
exp ...))))
-(define (partition-image image partition)
- (let* ((os (image-operating-system image))
- (bootloader (bootloader-configuration-bootloader
- (operating-system-bootloader os)))
- (bootcfg (operating-system-bootcfg os))
- (inputs `(("system" ,os)
- ("bootcfg" ,bootcfg)))
- (schema (local-file (search-path %load-path
- "guix/store/schema.sql")))
- (graph (match inputs
- (((names . _) ...)
- names)))
- (root-builder
- (with-imported-modules*
- (let* ((initializer #$(partition-initializer partition)))
- (sql-schema #$schema)
-
- ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
- (setenv "GUIX_LOCPATH"
- #+(file-append glibc-utf8-locales "/lib/locale"))
- (setlocale LC_ALL "en_US.utf8")
-
- (initializer #$output
- #:references-graphs '#$graph
- #:deduplicate? #f
- #:system-directory #$os
- #:bootloader-package
- #$(bootloader-package bootloader)
- #:bootcfg #$bootcfg
- #:bootcfg-location
- #$(bootloader-configuration-file bootloader)))))
- (image-root
- (computed-file "partition-image-root" root-builder
- #:options `(#:references-graphs ,inputs)))
- (type (partition-file-system partition))
- (image-builder
- (with-imported-modules*
- (let ((inputs '#$(list e2fsprogs ;mke2fs
- dosfstools ;mkdosfs
- mtools ;mcopy
- )))
- (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
- (make-partition-image #$(partition->gexp partition)
- #$output
- #$image-root)))))
- (computed-file "partition.img" image-builder)))
-
-(define genimage-name "image")
-
-(define (image->genimage-cfg image)
- (define (format->image-type format)
- (case format
- ((disk-image) "hdimage")
- (else
- (error
- (format #f "Unsupported image type ~a~%." format)))))
-
- (define (partition->dos-type partition)
- (let ((flags (partition-flags partition)))
- (cond
- ((member 'esp flags) "0xEF")
- (else "0x83"))))
-
- (define (partition->config partition)
- (let ((label (partition-label partition))
- (dos-type (partition->dos-type partition))
- (image (partition-image image partition)))
- #~(format #f "~/partition ~a {
+
+;;
+;; Disk image.
+;;
+
+(define* (system-disk-image image
+ #:key
+ (name "disk-image")
+ label
+ uuid
+ bootcfg
+ bootloader
+ register-closures?
+ (inputs '())
+ (substitutable? #t))
+
+ (define genimage-name "image")
+
+ (define (image->genimage-cfg image)
+ (define (format->image-type format)
+ (case format
+ ((disk-image) "hdimage")
+ (else
+ (error
+ (format #f "Unsupported image type ~a~%." format)))))
+
+ (define (partition->dos-type partition)
+ (let ((flags (partition-flags partition)))
+ (cond
+ ((member 'esp flags) "0xEF")
+ (else "0x83"))))
+
+ (define (partition->config partition)
+ (let ((label (partition-label partition))
+ (dos-type (partition->dos-type partition))
+ (image (partition-image partition)))
+ #~(format #f "~/partition ~a {
~/~/partition-type = ~a
~/~/image = \"~a\"
~/}" #$label #$dos-type #$image)))
- (let* ((format (image-format image))
- (image-type (format->image-type format))
- (partitions (image-partitions image))
- (partitions-config (map partition->config partitions))
- (builder
- #~(begin
- (let ((format (@ (ice-9 format) format)))
- (call-with-output-file #$output
- (lambda (port)
- (format port
- "\
+ (let* ((format (image-format image))
+ (image-type (format->image-type format))
+ (partitions (image-partitions image))
+ (partitions-config (map partition->config partitions))
+ (builder
+ #~(begin
+ (let ((format (@ (ice-9 format) format)))
+ (call-with-output-file #$output
+ (lambda (port)
+ (format port
+ "\
image ~a {
~/~a {}
~{~a~^~%~}
}~%" #$genimage-name #$image-type (list #$@partitions-config))))))))
- (computed-file "genimage.cfg" builder)))
+ (computed-file "genimage.cfg" builder)))
-(define (system-iso9660-image image)
- (let* ((image-os (image-operating-system image))
- (file-systems-to-keep
- (remove (lambda (fs)
- (string=? (file-system-mount-point fs) "/"))
- (operating-system-file-systems image-os)))
- (os (operating-system
- (inherit image-os)
- (initrd (lambda (file-systems . rest)
- (apply (operating-system-initrd image-os)
- file-systems
- #:volatile-root? #t
- rest)))
- (bootloader (bootloader-configuration
- (inherit (operating-system-bootloader
- image-os))
- (bootloader grub-mkrescue-bootloader)))
- (file-systems (cons (file-system
- (mount-point "/")
- (device "/dev/placeholder")
- (type "iso9660"))
- file-systems-to-keep))))
- (uuid (root-iso-uuid os))
- (os (operating-system
- (inherit os)
- (file-systems (cons (file-system
- (mount-point "/")
- (device uuid)
- (type "iso9660"))
- file-systems-to-keep))))
- (bootloader (bootloader-configuration-bootloader
- (operating-system-bootloader os)))
- (bootcfg (operating-system-bootcfg os))
- (inputs `(("system" ,os)
- ("bootcfg" ,bootcfg)))
+ (define (partition-image partition)
+ (let* ((os (image-operating-system image))
+ (schema (local-file (search-path %load-path
+ "guix/store/schema.sql")))
+ (graph (match inputs
+ (((names . _) ...)
+ names)))
+ (root-builder
+ (with-imported-modules*
+ (let* ((initializer #$(partition-initializer partition)))
+ (sql-schema #$schema)
+
+ ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
+ (setenv "GUIX_LOCPATH"
+ #+(file-append glibc-utf8-locales "/lib/locale"))
+ (setlocale LC_ALL "en_US.utf8")
+
+ (initializer #$output
+ #:references-graphs '#$graph
+ #:deduplicate? #f
+ #:system-directory #$os
+ #:bootloader-package #$bootloader
+ #:bootcfg #$bootcfg
+ #:bootcfg-location
+ #$(bootloader-configuration-file bootloader)))))
+ (image-root
+ (computed-file "partition-image-root" root-builder
+ #:options `(#:references-graphs ,inputs)))
+ (type (partition-file-system partition))
+ (image-builder
+ (with-imported-modules*
+ (let ((inputs '#$(list e2fsprogs dosfstools mtools)))
+ (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+ (make-partition-image #$(partition->gexp partition)
+ #$output
+ #$image-root)))))
+ (computed-file "partition.img" image-builder)))
+
+ (let* ((builder
+ (with-imported-modules*
+ (let ((inputs '#$(list genimage coreutils findutils)))
+ (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+ (genimage #$(image->genimage-cfg image) #$output))))
+ (image-dir (computed-file "image-dir" builder)))
+ (gexp->derivation "image"
+ #~(symlink
+ (string-append #$image-dir "/" #$genimage-name)
+ #$output))))
+
+
+;;
+;; ISO9660 image.
+;;
+
+(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)))))
+
+(define* (system-iso9660-image image
+ #:key
+ (name "iso9660-image")
+ label
+ uuid
+ bootcfg
+ bootloader
+ register-closures?
+ (inputs '())
+ (grub-mkrescue-environment '())
+ (substitutable? #t))
+ (let* ((os (image-operating-system image))
(schema (local-file (search-path %load-path
"guix/store/schema.sql")))
(graph (match inputs
@@ -333,39 +302,106 @@ image ~a {
sed grep coreutils findutils gawk)))
(set-path-environment-variable "PATH" '("bin" "sbin") inputs)
(make-iso9660-image #$xorriso
- '(("MKRESCUE_SED_MODE" . "mbr_hfs"))
- #$(bootloader-package bootloader)
+ '#$grub-mkrescue-environment
+ #$bootloader
#$bootcfg
#$os
#$image-root
#$output
#:references-graphs '#$graph
- #:register-closures? #t
+ #:register-closures? #$register-closures?
#:compression? #f
- #:volume-id #$root-iso-label
+ #:volume-id #$label
#:volume-uuid #$(and=> uuid
uuid-bytevector))))))
- (gexp->derivation "iso.img" builder
+ (gexp->derivation name builder
#:references-graphs inputs)))
-(define* (system-disk-image image)
- (let* ((builder
- (with-imported-modules*
- (let ((inputs '#$(list genimage ;genimage
- coreutils ;rm
- findutils ;find
- )))
- (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
- (genimage #$(image->genimage-cfg image) #$output))))
- (image-dir (computed-file "image-dir" builder)))
- (gexp->derivation "image"
- #~(symlink
- (string-append #$image-dir "/" #$genimage-name)
- #$output))))
+
+;;
+;; Image creation.
+;;
+
+(define (image->root-file-system image)
+ (define (find-root-partition)
+ (let ((partitions (image-partitions image)))
+ (find (lambda (partition)
+ (member (partition-flags partition) 'boot))
+ partitions)))
+
+ (let ((format (image-format image)))
+ (if (eq? format 'iso9660)
+ "iso9660"
+ (partition-file-system (find-root-partition)))))
-(define (system-image image)
- (case (image-format image)
- ((disk-image)
- (system-disk-image image))
- ((iso9660)
- (system-iso9660-image image))))
+(define-syntax-rule (image-with-os base-image os)
+ (image
+ (inherit base-image)
+ (operating-system os)))
+
+(define* (system-image image
+ #:key
+ (substitutable? #t))
+ (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)))
+ (root-file-system-type (image->root-file-system image))
+ (os (operating-system
+ (inherit image-os)
+ (initrd (lambda (file-systems . rest)
+ (apply (operating-system-initrd image-os)
+ file-systems
+ #:volatile-root? #t
+ rest)))
+ (bootloader (if (eq? format 'iso9660)
+ (bootloader-configuration
+ (inherit
+ (operating-system-bootloader image-os))
+ (bootloader grub-mkrescue-bootloader))
+ (operating-system-bootloader image-os)))
+ (file-systems (cons (file-system
+ (mount-point "/")
+ (device "/dev/placeholder")
+ (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
+ (mount-point "/")
+ (device uuid)
+ (type root-file-system-type))
+ file-systems-to-keep))))
+ (image* (image-with-os image os))
+ (register-closures? (has-guix-service-type? os))
+ (bootcfg (operating-system-bootcfg os))
+ (bootloader (bootloader-package
+ (bootloader-configuration-bootloader
+ (operating-system-bootloader os)))))
+ (case (image-format image)
+ ((disk-image)
+ (system-disk-image image*
+ #:label label
+ #:uuid uuid
+ #:bootcfg bootcfg
+ #:bootloader bootloader
+ #:register-closures? register-closures?
+ #:inputs `(("system" ,os)
+ ("bootcfg" ,bootcfg))
+ #:substitutable? substitutable?))
+ ((iso9660)
+ (system-iso9660-image image*
+ #:label label
+ #:uuid uuid
+ #:bootcfg bootcfg
+ #:bootloader bootloader
+ #:register-closures? register-closures?
+ #:inputs `(("system" ,os)
+ ("bootcfg" ,bootcfg))
+ #:grub-mkrescue-environment
+ '(("MKRESCUE_SED_MODE" . "mbr_hfs"))
+ #:substitutable? substitutable?)))))
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index c9741fb..78f6f2d 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -606,55 +606,6 @@ system."
;;; VM and disk images.
;;;
-(define* (operating-system-uuid os #:optional (type 'dce))
- "Compute UUID object with a deterministic \"UUID\" for OS, of the given
-TYPE (one of 'iso9660 or 'dce). Return a UUID object."
- ;; Note: For this to be deterministic, we must not hash things that contains
- ;; (directly or indirectly) procedures, for example. That rules out
- ;; anything that contains gexps, thunk or delayed record fields, etc.
-
- (define service-name
- (compose service-type-name service-kind))
-
- (define (file-system-digest fs)
- ;; Return a hashable digest that does not contain 'dependencies' since
- ;; this field can contain procedures.
- (let ((device (file-system-device fs)))
- (list (file-system-mount-point fs)
- (file-system-type fs)
- (file-system-device->string device)
- (file-system-options fs))))
-
- (if (eq? type 'iso9660)
- (let ((pad (compose (cut string-pad <> 2 #\0)
- number->string))
- (h (hash (map service-name (operating-system-services os))
- 3600)))
- (bytevector->uuid
- (string->iso9660-uuid
- (string-append "1970-01-01-"
- (pad (hash (operating-system-host-name os) 24)) "-"
- (pad (quotient h 60)) "-"
- (pad (modulo h 60)) "-"
- (pad (hash (map file-system-digest
- (operating-system-file-systems os))
- 100))))
- 'iso9660))
- (bytevector->uuid
- (uint-list->bytevector
- (list (hash (map file-system-digest
- (operating-system-file-systems os))
- (- (expt 2 32) 1))
- (hash (operating-system-host-name os)
- (- (expt 2 32) 1))
- (hash (map service-name (operating-system-services os))
- (- (expt 2 32) 1))
- (hash (map file-system-digest (operating-system-file-systems os))
- (- (expt 2 32) 1)))
- (endianness little)
- 4)
- type)))
-
(define* (system-disk-image-in-vm os
#:key
(name "disk-image")