mothacehe pushed a commit to branch wip-disk-image
in repository guix.
commit 136e14cc8f31ddc3f19febe7b91142e13f6c4467
Author: Mathieu Othacehe <[email protected]>
AuthorDate: Wed Apr 8 18:08:04 2020 +0200
wip: Use mke2fs to generate disk-images.
---
Makefile.am | 1 +
gnu/ci.scm | 14 +++++-----
gnu/system/vm.scm | 65 ++++++++++++++++++++++++++++++++++++++++++-----
gnu/tests/install.scm | 2 +-
guix/build/disk-image.scm | 26 +++++++++++++++++++
guix/scripts/system.scm | 20 +++++++++------
6 files changed, 105 insertions(+), 23 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 344ecdb..60e4ac5 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -171,6 +171,7 @@ MODULES = \
guix/build/asdf-build-system.scm \
guix/build/bzr.scm \
guix/build/copy-build-system.scm \
+ guix/build/disk-image.scm \
guix/build/git.scm \
guix/build/hg.scm \
guix/build/glib-or-gtk-build-system.scm \
diff --git a/gnu/ci.scm b/gnu/ci.scm
index fb2596c..7fd5577 100644
--- a/gnu/ci.scm
+++ b/gnu/ci.scm
@@ -214,7 +214,7 @@ system.")
(run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
- (system-disk-image
+ (system-disk-image-in-vm
(operating-system (inherit installation-os)
(bootloader (bootloader-configuration
(bootloader u-boot-bootloader)
@@ -225,16 +225,16 @@ system.")
(run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
- (system-disk-image installation-os
- #:disk-image-size
- (* 1500 MiB)))))
+ (system-disk-image-in-vm installation-os
+ #:disk-image-size
+ (* 1500 MiB)))))
(->job 'iso9660-image
(run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
- (system-disk-image installation-os
- #:file-system-type
- "iso9660"))))))
+ (system-disk-image-in-vm installation-os
+ #:file-system-type
+ "iso9660"))))))
'()))
(define channel-build-system
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 60a4158..63da1eb 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -79,6 +79,7 @@
system-qemu-image/shared-store
system-qemu-image/shared-store-script
+ system-disk-image-in-vm
system-disk-image
system-docker-image
@@ -653,13 +654,13 @@ TYPE (one of 'iso9660 or 'dce). Return a UUID object."
4)
type)))
-(define* (system-disk-image os
- #:key
- (name "disk-image")
- (file-system-type "ext4")
- (disk-image-size (* 900 (expt 2 20)))
- (volatile? #t)
- (substitutable? #t))
+(define* (system-disk-image-in-vm os
+ #:key
+ (name "disk-image")
+ (file-system-type "ext4")
+ (disk-image-size (* 900 (expt 2 20)))
+ (volatile? #t)
+ (substitutable? #t))
"Return the derivation of a disk image of DISK-IMAGE-SIZE bytes of the
system described by OS. Said image can be copied on a USB stick as is. When
VOLATILE? is true, the root file system is made volatile; this is useful
@@ -751,6 +752,56 @@ substitutable."
("bootcfg" ,bootcfg))
#:substitutable? substitutable?))))
+(define* (system-disk-image os
+ #:key
+ (name "disk-image")
+ (file-system-type "ext4")
+ (disk-image-size 'guess)
+ (volatile? #t)
+ (substitutable? #t))
+ (let* ((inputs `(("system" ,os)))
+ (graph (match inputs
+ (((names . _) ...)
+ names)))
+ (store-builder
+ (with-imported-modules `(,@(source-module-closure
+ '((guix build store-copy))
+ #:select? not-config?)
+
+ ;; For consumption by (gnu store database).
+ ((guix config) => ,(make-config.scm)))
+ #~(begin
+ (use-modules (guix build store-copy))
+ (populate-store '#$graph #$output))))
+ (builder
+ (with-imported-modules `(,@(source-module-closure
+ '((guix build disk-image)
+ (guix build store-copy)
+ (guix build utils))
+ #:select? not-config?)
+
+ ;; For consumption by (gnu store database).
+ ((guix config) => ,(make-config.scm)))
+ #~(begin
+ (use-modules (guix build disk-image)
+ (guix build store-copy)
+ (guix build utils))
+
+ (let* ((inputs '#$(list e2fsprogs)) ;mke2fs
+ (root #$(computed-file "store" store-builder
+ #:options
+ `(#:references-graphs ,inputs)))
+ (root-size
+ #$(if (eq? disk-image-size 'guess)
+ #~(round (/ (* 1.25 (closure-size '#$graph))
+ 1024))
+ disk-image-size)))
+ (set-path-environment-variable "PATH" '("bin" "sbin")
+ inputs)
+ (make-ext4-image root #$output root-size))))))
+ (gexp->derivation name builder
+ #:references-graphs inputs)))
+
(define* (system-qemu-image os
#:key
(file-system-type "ext4")
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
index 799a659..07fe5bb 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -227,7 +227,7 @@ packages defined in installation-os."
;; we cheat a little bit by adding TARGET to its GC
;; roots. This way, we know 'guix system init' will
;; succeed.
- (image (system-disk-image
+ (image (system-disk-image-in-vm
(operating-system-with-gc-roots
os (list target))
#:disk-image-size install-size
diff --git a/guix/build/disk-image.scm b/guix/build/disk-image.scm
new file mode 100644
index 0000000..0b14957
--- /dev/null
+++ b/guix/build/disk-image.scm
@@ -0,0 +1,26 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Mathieu Othacehe <[email protected]>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build disk-image)
+ #:use-module (guix build store-copy)
+ #:use-module (guix build utils)
+ #:export (make-ext4-image))
+
+(define (make-ext4-image root output size)
+ (invoke "mke2fs" "-t" "ext4" "-d" root output
+ (number->string (inexact->exact size))))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 2664c66..f8d9321 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -691,13 +691,15 @@ checking this by themselves in their 'check' procedure."
image-size
(* 70 (expt 2 20)))
#:mappings mappings))
+ ((disk-image-vm)
+ (system-disk-image-in-vm os
+ #:name (match file-system-type
+ ("iso9660" "image.iso")
+ (_ "disk-image"))
+ #:disk-image-size image-size
+ #:file-system-type file-system-type))
((disk-image)
- (system-disk-image os
- #:name (match file-system-type
- ("iso9660" "image.iso")
- (_ "disk-image"))
- #:disk-image-size image-size
- #:file-system-type file-system-type))
+ (system-disk-image os))
((docker-image)
(system-docker-image os))))
@@ -1226,7 +1228,8 @@ argument list and OPTS is the option alist."
(alist-cons 'argument arg result)
(let ((action (string->symbol arg)))
(case action
- ((build container vm vm-image disk-image reconfigure init
+ ((build container vm vm-image disk-image disk-image-vm
+ reconfigure init
extension-graph shepherd-graph
list-generations describe
delete-generations roll-back
@@ -1259,7 +1262,8 @@ argument list and OPTS is the option alist."
(exit 1))
(case action
- ((build container vm vm-image disk-image docker-image reconfigure)
+ ((build container vm vm-image disk-image disk-image-vm docker-image
+ reconfigure)
(unless (or (= count 1)
(and expr (= count 0)))
(fail)))
