[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/02: Add iso support.
|
From: |
guix-commits |
|
Subject: |
02/02: Add iso support. |
|
Date: |
Fri, 24 Apr 2020 03:18:09 -0400 (EDT) |
mothacehe pushed a commit to branch wip-disk-image
in repository guix.
commit 417697d7ef401fe8665383a2853a64c7261fb634
Author: Mathieu Othacehe <address@hidden>
AuthorDate: Fri Apr 24 09:17:51 2020 +0200
Add iso support.
---
gnu/build/disk-image.scm | 73 ++++++++++++++++++++-
gnu/build/vm.scm | 129 +------------------------------------
gnu/system/image.scm | 162 ++++++++++++++++++++++++++++++++++++++++++++++-
guix/scripts/system.scm | 17 ++---
4 files changed, 240 insertions(+), 141 deletions(-)
diff --git a/gnu/build/disk-image.scm b/gnu/build/disk-image.scm
index 7423a93..05b40bb 100644
--- a/gnu/build/disk-image.scm
+++ b/gnu/build/disk-image.scm
@@ -25,14 +25,18 @@
#:use-module (gnu build install)
#:use-module (gnu build linux-boot)
#:use-module (gnu image)
+ #:use-module (gnu system uuid)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
+ #:use-module (srfi srfi-19)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:export (make-partition-image
genimage
initialize-efi-partition
- initialize-root-partition))
+ initialize-root-partition
+
+ make-iso9660-image))
(define (sexp->partition sexp)
(match sexp
@@ -149,3 +153,70 @@ deduplicates files common to CLOSURE and the rest of
PREFIX."
;; Register BOOTCFG as a GC root.
(register-bootcfg-root root bootcfg))
+
+(define* (make-iso9660-image xorriso grub-mkrescue-environment
+ grub bootcfg system-directory root target
+ #:key (volume-id "Guix_image") (volume-uuid #f)
+ register-closures? (references-graphs '()))
+ "Given a GRUB package, creates an iso image as TARGET, using BOOTCFG as
+GRUB configuration and OS-DRV as the stuff in it."
+ (define grub-mkrescue
+ (string-append grub "/bin/grub-mkrescue"))
+
+ (define grub-mkrescue-sed.sh
+ (string-append (getcwd) "/" "grub-mkrescue-sed.sh"))
+
+ (copy-file (string-append xorriso
+ "/bin/grub-mkrescue-sed.sh")
+ grub-mkrescue-sed.sh)
+ (substitute* grub-mkrescue-sed.sh
+ (("/tmp/") (string-append (getcwd) "/"))
+ (("MKRESCUE_SED_XORRISO_ARGS \\$x")
+ (format #f "MKRESCUE_SED_XORRISO_ARGS $(echo $x | sed \"s|/tmp|~a|\")"
+ (getcwd))))
+
+ ;; 'grub-mkrescue' calls out to mtools programs to create 'efi.img', a FAT
+ ;; file system image, and mtools honors SOURCE_DATE_EPOCH for the mtime of
+ ;; those files. The epoch for FAT is Jan. 1st 1980, not 1970, so choose
+ ;; that.
+ (setenv "SOURCE_DATE_EPOCH"
+ (number->string
+ (time-second
+ (date->time-utc (make-date 0 0 0 0 1 1 1980 0)))))
+
+ ;; Our patched 'grub-mkrescue' honors this environment variable and passes
+ ;; it to 'mformat', which makes it the serial number of 'efi.img'. This
+ ;; allows for deterministic builds.
+ (setenv "GRUB_FAT_SERIAL_NUMBER"
+ (number->string (if volume-uuid
+
+ ;; On 32-bit systems the 2nd argument must be
+ ;; lower than 2^32.
+ (string-hash (iso9660-uuid->string volume-uuid)
+ (- (expt 2 32) 1))
+
+ #x77777777)
+ 16))
+
+ (setenv "MKRESCUE_SED_MODE" "original")
+ (setenv "MKRESCUE_SED_XORRISO" (string-append xorriso "/bin/xorriso"))
+ (setenv "MKRESCUE_SED_IN_EFI_NO_PT" "yes")
+
+ (for-each (match-lambda
+ ((name . value) (setenv name value)))
+ grub-mkrescue-environment)
+
+ (apply invoke grub-mkrescue
+ (string-append "--xorriso=" grub-mkrescue-sed.sh)
+ "-o" target
+ (string-append "boot/grub/grub.cfg=" bootcfg)
+ root
+ "--"
+ "-volid" (string-upcase volume-id)
+ (if volume-uuid
+ `("-volume_date" "uuid"
+ ,(string-filter (lambda (value)
+ (not (char=? #\- value)))
+ (iso9660-uuid->string
+ volume-uuid)))
+ `())))
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 4db9b7e..1a888b1 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -57,8 +57,7 @@
estimated-partition-size
root-partition-initializer
initialize-partition-table
- initialize-hard-disk
- make-iso9660-image))
+ initialize-hard-disk))
;;; Commentary:
;;;
@@ -417,132 +416,6 @@ SYSTEM-DIRECTORY is the name of the directory of the
'system' derivation."
(mkdir-p directory)
(symlink bootcfg (string-append directory "/bootcfg"))))
-(define* (make-iso9660-image xorriso grub-mkrescue-environment
- grub config-file os-drv target
- #:key (volume-id "Guix_image") (volume-uuid #f)
- register-closures? (closures '()))
- "Given a GRUB package, creates an iso image as TARGET, using CONFIG-FILE as
-GRUB configuration and OS-DRV as the stuff in it."
- (define grub-mkrescue
- (string-append grub "/bin/grub-mkrescue"))
-
- (define grub-mkrescue-sed.sh
- (string-append xorriso "/bin/grub-mkrescue-sed.sh"))
-
- (define target-store
- (string-append "/tmp/root" (%store-directory)))
-
- (define items
- ;; The store items to add to the image.
- (delete-duplicates
- (append-map (lambda (closure)
- (map store-info-item
- (call-with-input-file (string-append "/xchg/" closure)
- read-reference-graph)))
- closures)))
-
- (populate-root-file-system os-drv "/tmp/root")
- (mount (%store-directory) target-store "" MS_BIND)
-
- (when register-closures?
- (display "registering closures...\n")
- (for-each (lambda (closure)
- (register-closure
- "/tmp/root"
- (string-append "/xchg/" closure)
-
- ;; TARGET-STORE is a read-only bind-mount so we shouldn't try
- ;; to modify it.
- #:deduplicate? #f
- #:reset-timestamps? #f))
- closures)
- (register-bootcfg-root "/tmp/root" config-file))
-
- ;; 'grub-mkrescue' calls out to mtools programs to create 'efi.img', a FAT
- ;; file system image, and mtools honors SOURCE_DATE_EPOCH for the mtime of
- ;; those files. The epoch for FAT is Jan. 1st 1980, not 1970, so choose
- ;; that.
- (setenv "SOURCE_DATE_EPOCH"
- (number->string
- (time-second
- (date->time-utc (make-date 0 0 0 0 1 1 1980 0)))))
-
- ;; Our patched 'grub-mkrescue' honors this environment variable and passes
- ;; it to 'mformat', which makes it the serial number of 'efi.img'. This
- ;; allows for deterministic builds.
- (setenv "GRUB_FAT_SERIAL_NUMBER"
- (number->string (if volume-uuid
-
- ;; On 32-bit systems the 2nd argument must be
- ;; lower than 2^32.
- (string-hash (iso9660-uuid->string volume-uuid)
- (- (expt 2 32) 1))
-
- #x77777777)
- 16))
-
- (setenv "MKRESCUE_SED_MODE" "original")
- (setenv "MKRESCUE_SED_XORRISO" (string-append xorriso
- "/bin/xorriso"))
- (setenv "MKRESCUE_SED_IN_EFI_NO_PT" "yes")
- (for-each (match-lambda
- ((name . value) (setenv name value)))
- grub-mkrescue-environment)
-
- (let ((pipe
- (apply open-pipe* OPEN_WRITE
- grub-mkrescue
- (string-append "--xorriso=" grub-mkrescue-sed.sh)
- "-o" target
- (string-append "boot/grub/grub.cfg=" config-file)
- "etc=/tmp/root/etc"
- "var=/tmp/root/var"
- "run=/tmp/root/run"
- ;; /mnt is used as part of the installation
- ;; process, as the mount point for the target
- ;; file system, so create it.
- "mnt=/tmp/root/mnt"
- "-path-list" "-"
- "--"
-
- ;; Set all timestamps to 1.
- "-volume_date" "all_file_dates" "=1"
-
- ;; ‘zisofs’ compression reduces the total image size by ~60%.
- "-zisofs" "level=9:block_size=128k" ; highest compression
- ;; It's transparent to our Linux-Libre kernel but not to GRUB.
- ;; Don't compress the kernel, initrd, and other files read by
- ;; grub.cfg, as well as common already-compressed file names.
- "-find" "/" "-type" "f"
- ;; XXX Even after "--" above, and despite documentation
claiming
- ;; otherwise, "-or" is stolen by grub-mkrescue which then
chokes
- ;; on it (as ‘-o …’) and dies. Don't use "-or".
- "-not" "-wholename" "/boot/*"
- "-not" "-wholename" "/System/*"
- "-not" "-name" "unicode.pf2"
- "-not" "-name" "bzImage"
- "-not" "-name" "*.gz" ; initrd & all man pages
- "-not" "-name" "*.png" ; includes grub-image.png
- "-exec" "set_filter" "--zisofs"
- "--"
-
- "-volid" (string-upcase volume-id)
- (if volume-uuid
- `("-volume_date" "uuid"
- ,(string-filter (lambda (value)
- (not (char=? #\- value)))
- (iso9660-uuid->string
- volume-uuid)))
- `()))))
- ;; Pass lines like 'gnu/store/…-x=/gnu/store/…-x' corresponding to the
- ;; '-path-list -' option.
- (for-each (lambda (item)
- (format pipe "~a=~a~%"
- (string-drop item 1) item))
- items)
- (unless (zero? (close-pipe pipe))
- (error "oh, my! grub-mkrescue failed" grub-mkrescue))))
-
(define* (initialize-hard-disk device
#:key
bootloader-package
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index 3057c51..916f4d4 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -23,22 +23,35 @@
#:use-module (guix utils)
#:use-module ((guix self) #:select (make-config.scm))
#:use-module (gnu bootloader)
+ #:use-module (gnu bootloader grub)
#:use-module (gnu image)
+ #:use-module (gnu services)
#:use-module (gnu system)
+ #:use-module (gnu system file-systems)
+ #:use-module (gnu system uuid)
#:use-module (guix packages)
#:use-module (gnu packages base)
+ #:use-module (gnu packages bootloaders)
+ #:use-module (gnu packages cdrom)
#:use-module (gnu packages disk)
+ #:use-module (gnu packages gawk)
#:use-module (gnu packages genimage)
#:use-module (gnu packages guile)
#:autoload (gnu packages gnupg) (guile-gcrypt)
#:use-module (gnu packages linux)
#:use-module (gnu packages mtools)
- #:use-module ((srfi srfi-1) #:select (append-map))
+ #:use-module ((srfi srfi-1) #:select (append-map remove))
+ #:use-module (srfi srfi-26)
+ #:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
#:export (esp-partition
root-partition
+
efi-disk-image
+ iso9660-image
+ system-iso9660-image
+ system-disk-image
system-image))
@@ -70,6 +83,68 @@
(format 'disk-image)
(partitions (list esp-partition root-partition))))
+(define iso9660-image
+ (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)
+ ;; 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))
+
(define not-config?
;; Select (guix …) and (gnu …) modules, except (guix config).
(match-lambda
@@ -190,7 +265,83 @@ image ~a {
}~%" #$genimage-name #$image-type (list #$@partitions-config))))))))
(computed-file "genimage.cfg" builder)))
-(define* (system-image image)
+(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)))
+ (schema (local-file (search-path %load-path
+ "guix/store/schema.sql")))
+ (graph (match inputs
+ (((names . _) ...)
+ names)))
+ (root-builder
+ (with-imported-modules*
+ (sql-schema #$schema)
+ (initialize-root-partition #$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 "image-root" root-builder
+ #:options `(#:references-graphs ,inputs)))
+ (builder
+ (with-imported-modules*
+ (let* ((inputs '#$(list parted e2fsprogs dosfstools xorriso
+ 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)
+ #$bootcfg
+ #$os
+ #$image-root
+ #$output
+ #:references-graphs '#$graph
+ #:register-closures? #t
+ #:volume-id #$root-iso-label
+ #:volume-uuid #$(and=> uuid
+ uuid-bytevector))))))
+ (gexp->derivation "iso.img" builder
+ #:references-graphs inputs)))
+
+(define* (system-disk-image image)
(let* ((builder
(with-imported-modules*
(let ((inputs '#$(list genimage ;genimage
@@ -204,3 +355,10 @@ image ~a {
#~(symlink
(string-append #$image-dir "/" #$genimage-name)
#$output))))
+
+(define (system-image image)
+ (case (image-format image)
+ ((disk-image)
+ (system-disk-image image))
+ ((iso9660)
+ (system-iso9660-image image))))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 2f3c914..c59a4b1 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -694,16 +694,13 @@ checking this by themselves in their 'check' procedure."
(* 70 (expt 2 20)))
#:mappings mappings))
((disk-image)
- (match file-system-type
- ("iso9660"
- (system-disk-image-in-vm os
- #:name "image.iso"
- #:disk-image-size image-size
- #:file-system-type file-system-type))
- (_ (system-image
- (image
- (inherit efi-disk-image)
- (operating-system os))))))
+ (let ((image-base (match file-system-type
+ ("iso9660" iso9660-image)
+ (_ efi-disk-image))))
+ (system-image
+ (image
+ (inherit image-base)
+ (operating-system os)))))
((docker-image)
(system-docker-image os))))