system: image: Add image-type support.
* 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
Mathieu Othacehe
parent
99d036ce84
commit
10b135cef5
|
|
@ -18,6 +18,8 @@
|
|||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (gnu system image)
|
||||
#:use-module (guix diagnostics)
|
||||
#:use-module (guix discovery)
|
||||
#:use-module (guix gexp)
|
||||
#:use-module (guix modules)
|
||||
#:use-module (guix monads)
|
||||
|
|
@ -64,9 +66,16 @@
|
|||
efi-disk-image
|
||||
iso9660-image
|
||||
|
||||
find-image
|
||||
image-with-os
|
||||
raw-image-type
|
||||
iso-image-type
|
||||
uncompressed-iso-image-type
|
||||
|
||||
image-with-label
|
||||
system-image
|
||||
image-with-label))
|
||||
|
||||
%image-types
|
||||
lookup-image-type-by-name))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
@ -113,6 +122,37 @@
|
|||
(label "GUIX_IMAGE")
|
||||
(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.
|
||||
|
|
@ -442,7 +482,7 @@ returns an image record where the first partition's label is set to <label>."
|
|||
image-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
|
||||
to OS. Also set the UUID and the size of the root partition."
|
||||
(define root-file-system
|
||||
|
|
@ -523,7 +563,7 @@ image, depending on IMAGE format."
|
|||
|
||||
(with-parameters ((%current-target-system target))
|
||||
(let* ((os (operating-system-for-image image))
|
||||
(image* (image-with-os image os))
|
||||
(image* (image-with-os* image os))
|
||||
(image-format (image-format image))
|
||||
(register-closures? (has-guix-service-type? os))
|
||||
(bootcfg (operating-system-bootcfg os))
|
||||
|
|
@ -556,18 +596,34 @@ image, depending on IMAGE format."
|
|||
#:grub-mkrescue-environment
|
||||
'(("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
|
||||
addition of the <image> record."
|
||||
(match file-system-type
|
||||
("iso9660" iso9660-image)
|
||||
(_ (cond
|
||||
((and target
|
||||
(hurd-triplet? target))
|
||||
(module-ref (resolve-interface '(gnu system images hurd))
|
||||
'hurd-disk-image))
|
||||
(else
|
||||
efi-disk-image)))))
|
||||
|
||||
;;
|
||||
;; Image detection.
|
||||
;;
|
||||
|
||||
(define (image-modules)
|
||||
"Return the list of image modules."
|
||||
(cons (resolve-interface '(gnu system image))
|
||||
(all-modules (map (lambda (entry)
|
||||
`(,entry . "gnu/system/images/"))
|
||||
%load-path)
|
||||
#:warn warn-about-load-error)))
|
||||
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -29,8 +29,11 @@
|
|||
#:use-module (gnu system file-systems)
|
||||
#:use-module (gnu system hurd)
|
||||
#:use-module (gnu system image)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:export (hurd-barebones-os
|
||||
hurd-disk-image
|
||||
hurd-image-type
|
||||
hurd-qcow2-image-type
|
||||
hurd-barebones-disk-image
|
||||
hurd-barebones-qcow2-image))
|
||||
|
||||
|
|
@ -83,14 +86,28 @@
|
|||
(flags '(boot))
|
||||
(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
|
||||
(image
|
||||
(inherit hurd-disk-image)
|
||||
(name 'hurd-barebones-disk-image)
|
||||
(operating-system hurd-barebones-os)))
|
||||
(inherit
|
||||
(os->image hurd-barebones-os #:type hurd-image-type))
|
||||
(name 'hurd-barebones-disk-image)))
|
||||
|
||||
(define hurd-barebones-qcow2-image
|
||||
(image
|
||||
(inherit hurd-barebones-disk-image)
|
||||
(name 'hurd-barebones.qcow2)
|
||||
(format 'compressed-qcow2)))
|
||||
(inherit
|
||||
(os->image hurd-barebones-os #:type hurd-qcow2-image-type))
|
||||
(name 'hurd-barebones.qcow2)))
|
||||
|
|
|
|||
|
|
@ -218,7 +218,7 @@ reboot\n")
|
|||
#:imported-modules '((gnu services herd)
|
||||
(gnu installer tests)
|
||||
(guix combinators))))
|
||||
(installation-disk-image-file-system-type "ext4")
|
||||
(installation-image-type 'raw)
|
||||
(install-size 'guess)
|
||||
(target-size (* 2200 MiB)))
|
||||
"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))
|
||||
(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,
|
||||
;; 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
|
||||
;; through provenance.drv and may not always be present.
|
||||
(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 ->
|
||||
(system-image
|
||||
(image
|
||||
(inherit base-image)
|
||||
(size install-size)
|
||||
(operating-system
|
||||
(operating-system-with-gc-roots
|
||||
os (list target guile-final)))
|
||||
;; Do not compress to speed-up the tests.
|
||||
(compression? #f)
|
||||
;; Don't provide substitutes; too big.
|
||||
(substitutable? #f)))))
|
||||
(system-image
|
||||
(image
|
||||
(inherit base-image)
|
||||
(size install-size)
|
||||
|
||||
;; Don't provide substitutes; too big.
|
||||
(substitutable? #f)))))
|
||||
(define install
|
||||
(with-imported-modules '((guix build utils)
|
||||
(gnu build marionette))
|
||||
|
|
@ -270,16 +268,16 @@ packages defined in installation-os."
|
|||
"-no-reboot"
|
||||
"-m" "1200"
|
||||
#$@(cond
|
||||
((string=? "ext4" installation-disk-image-file-system-type)
|
||||
((eq? 'raw installation-image-type)
|
||||
#~("-drive"
|
||||
,(string-append "file=" #$image
|
||||
",if=virtio,readonly")))
|
||||
((string=? "iso9660" installation-disk-image-file-system-type)
|
||||
((eq? 'uncompressed-iso9660 installation-image-type)
|
||||
#~("-cdrom" #$image))
|
||||
(else
|
||||
(error
|
||||
"unsupported installation-disk-image-file-system-type:"
|
||||
installation-disk-image-file-system-type)))
|
||||
"unsupported installation-image-type:"
|
||||
installation-image-type)))
|
||||
"-drive"
|
||||
,(string-append "file=" #$output ",if=virtio")
|
||||
,@(if (file-exists? "/dev/kvm")
|
||||
|
|
@ -443,8 +441,8 @@ reboot\n")
|
|||
%minimal-os-on-vda-source
|
||||
#:script
|
||||
%simple-installation-script-for-/dev/vda
|
||||
#:installation-disk-image-file-system-type
|
||||
"iso9660"))
|
||||
#:installation-image-type
|
||||
'uncompressed-iso9660))
|
||||
(command (qemu-command/writable-image image)))
|
||||
(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
|
||||
#:install-size install-size
|
||||
#:target-size target-size
|
||||
#:installation-disk-image-file-system-type
|
||||
"iso9660"
|
||||
#:installation-image-type
|
||||
'uncompressed-iso9660
|
||||
#:gui-test
|
||||
(lambda (marionette)
|
||||
(gui-test-program
|
||||
|
|
|
|||
Loading…
Reference in New Issue