me/guix
Archived
1
0
Fork 0
Code Activity

system: image: Add image-type support.

Browse source 
* gnu/system/image.scm (image-with-os): New macro. Rename the old
"image-with-os" procedure to ...
(image-with-os*): ... this new procedure,
(system-image): adapt according,
(raw-image-type, iso-image-type, uncompressed-iso-image-type
%image-types): new variables,
(lookup-image-type-by-name): new procedure.
(find-image): remove it.
* gnu/system/images/hurd.scm (hurd-image-type): New variable,
use it to define ...
(hurd-disk-image): ... this variable, using "os->image" procedure.
* gnu/tests/install.scm (run-install): Rename
installation-disk-image-file-system-type parameter to installation-image-type,
use os->config instead of find-image to compute the image passed to system-image,
(%test-iso-image-installer) adapt accordingly,
(guided-installation-test): ditto.

Signed-off-by: Mathieu Othacehe <othacehe@gnu.org>
This commit is contained in:
Mathieu Othacehe 2020-07-31 16:49:28 +02:00 • committed by Mathieu Othacehe
parent 99d036ce84
commit 10b135cef5
No known key found for this signature in database
GPG key ID: 8354763531769CA6
3 changed files with 118 additions and 47 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

90
gnu/system/image.scm
View file

@ -18,6 +18,8 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu system image) (define-module (gnu system image)
#:use-module (guix diagnostics)
#:use-module (guix discovery)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (guix modules) #:use-module (guix modules)
#:use-module (guix monads) #:use-module (guix monads)
@ -64,9 +66,16 @@
efi-disk-image efi-disk-image
iso9660-image iso9660-image
find-image image-with-os
raw-image-type
iso-image-type
uncompressed-iso-image-type
image-with-label
system-image system-image
image-with-label))
%image-types
lookup-image-type-by-name))
;;; ;;;
@ -113,6 +122,37 @@
(label "GUIX_IMAGE") (label "GUIX_IMAGE")
(flags '(boot))))))) (flags '(boot)))))))
;;;
;;; Images types.
;;;
(define-syntax-rule (image-with-os base-image os)
"Return an image inheriting from BASE-IMAGE, with the operating-system field
set to the given OS."
(image
(inherit base-image)
(operating-system os)))
(define raw-image-type
(image-type
(name 'raw)
(constructor (cut image-with-os efi-disk-image <>))))
(define iso-image-type
(image-type
(name 'iso9660)
(constructor (cut image-with-os iso9660-image <>))))
(define uncompressed-iso-image-type
(image-type
(name 'uncompressed-iso9660)
(constructor (cut image-with-os
(image
(inherit iso9660-image)
(compression? #f))
<>))))
;; ;;
;; Helpers. ;; Helpers.
@ -442,7 +482,7 @@ returns an image record where the first partition's label is set to <label>."
image-size) image-size)
(else root-size)))) (else root-size))))
(define* (image-with-os base-image os) (define* (image-with-os* base-image os)
"Return an image based on BASE-IMAGE but with the operating-system field set "Return an image based on BASE-IMAGE but with the operating-system field set
to OS. Also set the UUID and the size of the root partition." to OS. Also set the UUID and the size of the root partition."
(define root-file-system (define root-file-system
@ -523,7 +563,7 @@ image, depending on IMAGE format."
(with-parameters ((%current-target-system target)) (with-parameters ((%current-target-system target))
(let* ((os (operating-system-for-image image)) (let* ((os (operating-system-for-image image))
(image* (image-with-os image os)) (image* (image-with-os* image os))
(image-format (image-format image)) (image-format (image-format image))
(register-closures? (has-guix-service-type? os)) (register-closures? (has-guix-service-type? os))
(bootcfg (operating-system-bootcfg os)) (bootcfg (operating-system-bootcfg os))
@ -556,18 +596,34 @@ image, depending on IMAGE format."
#:grub-mkrescue-environment #:grub-mkrescue-environment
'(("MKRESCUE_SED_MODE" . "mbr_only")))))))) '(("MKRESCUE_SED_MODE" . "mbr_only"))))))))
(define (find-image file-system-type target)
"Find and return an image built that could match the given FILE-SYSTEM-TYPE, ;;
built for TARGET. This is useful to adapt to interfaces written before the ;; Image detection.
addition of the <image> record." ;;
(match file-system-type
("iso9660" iso9660-image) (define (image-modules)
(_ (cond "Return the list of image modules."
((and target (cons (resolve-interface '(gnu system image))
(hurd-triplet? target)) (all-modules (map (lambda (entry)
(module-ref (resolve-interface '(gnu system images hurd)) `(,entry . "gnu/system/images/"))
'hurd-disk-image)) %load-path)
(else #:warn warn-about-load-error)))
efi-disk-image)))))
(define %image-types
;; The list of publically-known image types.
(delay (fold-module-public-variables (lambda (obj result)
(if (image-type? obj)
(cons obj result)
result))
'()
(image-modules))))
(define (lookup-image-type-by-name name)
"Return the image type called NAME."
(or (srfi-1:find (lambda (image-type)
(eq? name (image-type-name image-type)))
(force %image-types))
(raise
(formatted-message (G_ "~a: no such image type~%") name))))
;;; image.scm ends here ;;; image.scm ends here

29
gnu/system/images/hurd.scm
View file

@ -29,8 +29,11 @@
#:use-module (gnu system file-systems) #:use-module (gnu system file-systems)
#:use-module (gnu system hurd) #:use-module (gnu system hurd)
#:use-module (gnu system image) #:use-module (gnu system image)
#:use-module (srfi srfi-26)
#:export (hurd-barebones-os #:export (hurd-barebones-os
hurd-disk-image hurd-disk-image
hurd-image-type
hurd-qcow2-image-type
hurd-barebones-disk-image hurd-barebones-disk-image
hurd-barebones-qcow2-image)) hurd-barebones-qcow2-image))
@ -83,14 +86,28 @@
(flags '(boot)) (flags '(boot))
(initializer hurd-initialize-root-partition)))))) (initializer hurd-initialize-root-partition))))))
(define hurd-image-type
(image-type
(name 'hurd-raw)
(constructor (cut image-with-os hurd-disk-image <>))))
(define hurd-qcow2-image-type
(image-type
(name 'hurd-qcow2)
(constructor (lambda (os)
(image
(inherit hurd-disk-image)
(format 'compressed-qcow2)
(operating-system os))))))
(define hurd-barebones-disk-image (define hurd-barebones-disk-image
(image (image
(inherit hurd-disk-image) (inherit
(name 'hurd-barebones-disk-image) (os->image hurd-barebones-os #:type hurd-image-type))
(operating-system hurd-barebones-os))) (name 'hurd-barebones-disk-image)))
(define hurd-barebones-qcow2-image (define hurd-barebones-qcow2-image
(image (image
(inherit hurd-barebones-disk-image) (inherit
(name 'hurd-barebones.qcow2) (os->image hurd-barebones-os #:type hurd-qcow2-image-type))
(format 'compressed-qcow2))) (name 'hurd-barebones.qcow2)))

46
gnu/tests/install.scm
View file

@ -218,7 +218,7 @@ reboot\n")
#:imported-modules '((gnu services herd) #:imported-modules '((gnu services herd)
(gnu installer tests) (gnu installer tests)
(guix combinators)))) (guix combinators))))
(installation-disk-image-file-system-type "ext4") (installation-image-type 'raw)
(install-size 'guess) (install-size 'guess)
(target-size (* 2200 MiB))) (target-size (* 2200 MiB)))
"Run SCRIPT (a shell script following the system installation procedure) in "Run SCRIPT (a shell script following the system installation procedure) in
@ -228,10 +228,6 @@ packages defined in installation-os."
(mlet* %store-monad ((_ (set-grafting #f)) (mlet* %store-monad ((_ (set-grafting #f))
(system (current-system)) (system (current-system))
(target (current-target-system))
(base-image -> (find-image
installation-disk-image-file-system-type
target))
;; Since the installation system has no network access, ;; Since the installation system has no network access,
;; we cheat a little bit by adding TARGET to its GC ;; we cheat a little bit by adding TARGET to its GC
@ -239,18 +235,20 @@ packages defined in installation-os."
;; succeed. Also add guile-final, which is pulled in ;; succeed. Also add guile-final, which is pulled in
;; through provenance.drv and may not always be present. ;; through provenance.drv and may not always be present.
(target (operating-system-derivation target-os)) (target (operating-system-derivation target-os))
(base-image ->
(os->image
(operating-system-with-gc-roots
os (list target guile-final))
#:type (lookup-image-type-by-name
installation-image-type)))
(image -> (image ->
(system-image (system-image
(image (image
(inherit base-image) (inherit base-image)
(size install-size) (size install-size)
(operating-system
(operating-system-with-gc-roots ;; Don't provide substitutes; too big.
os (list target guile-final))) (substitutable? #f)))))
;; Do not compress to speed-up the tests.
(compression? #f)
;; Don't provide substitutes; too big.
(substitutable? #f)))))
(define install (define install
(with-imported-modules '((guix build utils) (with-imported-modules '((guix build utils)
(gnu build marionette)) (gnu build marionette))
@ -270,16 +268,16 @@ packages defined in installation-os."
"-no-reboot" "-no-reboot"
"-m" "1200" "-m" "1200"
#$@(cond #$@(cond
((string=? "ext4" installation-disk-image-file-system-type) ((eq? 'raw installation-image-type)
#~("-drive" #~("-drive"
,(string-append "file=" #$image ,(string-append "file=" #$image
",if=virtio,readonly"))) ",if=virtio,readonly")))
((string=? "iso9660" installation-disk-image-file-system-type) ((eq? 'uncompressed-iso9660 installation-image-type)
#~("-cdrom" #$image)) #~("-cdrom" #$image))
(else (else
(error (error
"unsupported installation-disk-image-file-system-type:" "unsupported installation-image-type:"
installation-disk-image-file-system-type))) installation-image-type)))
"-drive" "-drive"
,(string-append "file=" #$output ",if=virtio") ,(string-append "file=" #$output ",if=virtio")
,@(if (file-exists? "/dev/kvm") ,@(if (file-exists? "/dev/kvm")
@ -443,8 +441,8 @@ reboot\n")
%minimal-os-on-vda-source %minimal-os-on-vda-source
#:script #:script
%simple-installation-script-for-/dev/vda %simple-installation-script-for-/dev/vda
#:installation-disk-image-file-system-type #:installation-image-type
"iso9660")) 'uncompressed-iso9660))
(command (qemu-command/writable-image image))) (command (qemu-command/writable-image image)))
(run-basic-test %minimal-os-on-vda command name))))) (run-basic-test %minimal-os-on-vda command name)))))
@ -1309,8 +1307,8 @@ build (current-guix) and then store a couple of full system images.")
#:os installation-os-for-gui-tests #:os installation-os-for-gui-tests
#:install-size install-size #:install-size install-size
#:target-size target-size #:target-size target-size
#:installation-disk-image-file-system-type #:installation-image-type
"iso9660" 'uncompressed-iso9660
#:gui-test #:gui-test
(lambda (marionette) (lambda (marionette)
(gui-test-program (gui-test-program