image: Add support for compressed-qcow2 format.
* gnu/build/image.scm (convert-disk-image): New procedure. (genimage): Remove target argument. * gnu/system/image.scm (system-disk-image): Add support for 'compressed-qcow2 image format. Call "convert-disk-image" to apply image conversions on the final image. Add "qemu-minimal" to the build inputs. (system-image): Also add support for 'compressed-qcow2.
This commit is contained in:
parent
c4d3eb569c
commit
f441e3e8b5
|
@ -37,6 +37,7 @@ (define-module (gnu build image)
|
||||||
#:use-module (srfi srfi-34)
|
#:use-module (srfi srfi-34)
|
||||||
#:use-module (srfi srfi-35)
|
#:use-module (srfi srfi-35)
|
||||||
#:export (make-partition-image
|
#:export (make-partition-image
|
||||||
|
convert-disk-image
|
||||||
genimage
|
genimage
|
||||||
initialize-efi-partition
|
initialize-efi-partition
|
||||||
initialize-root-partition
|
initialize-root-partition
|
||||||
|
@ -120,13 +121,22 @@ (define* (make-partition-image partition-sexp target root)
|
||||||
(format (current-error-port)
|
(format (current-error-port)
|
||||||
"Unsupported partition type~%.")))))
|
"Unsupported partition type~%.")))))
|
||||||
|
|
||||||
(define* (genimage config target)
|
(define (convert-disk-image image format output)
|
||||||
|
"Convert IMAGE to OUTPUT according to the given FORMAT."
|
||||||
|
(case format
|
||||||
|
((compressed-qcow2)
|
||||||
|
(begin
|
||||||
|
(invoke "qemu-img" "convert" "-c" "-f" "raw"
|
||||||
|
"-O" "qcow2" image output)))
|
||||||
|
(else
|
||||||
|
(copy-file image output))))
|
||||||
|
|
||||||
|
(define* (genimage config)
|
||||||
"Use genimage to generate in TARGET directory, the image described in the
|
"Use genimage to generate in TARGET directory, the image described in the
|
||||||
given CONFIG file."
|
given CONFIG file."
|
||||||
;; genimage needs a 'root' directory.
|
;; genimage needs a 'root' directory.
|
||||||
(mkdir "root")
|
(mkdir "root")
|
||||||
(invoke "genimage" "--config" config
|
(invoke "genimage" "--config" config))
|
||||||
"--outputpath" target))
|
|
||||||
|
|
||||||
(define* (register-closure prefix closure
|
(define* (register-closure prefix closure
|
||||||
#:key
|
#:key
|
||||||
|
|
|
@ -47,11 +47,13 @@ (define-module (gnu system image)
|
||||||
#:use-module (gnu packages hurd)
|
#:use-module (gnu packages hurd)
|
||||||
#:use-module (gnu packages linux)
|
#:use-module (gnu packages linux)
|
||||||
#:use-module (gnu packages mtools)
|
#:use-module (gnu packages mtools)
|
||||||
|
#:use-module (gnu packages virtualization)
|
||||||
#:use-module ((srfi srfi-1) #:prefix srfi-1:)
|
#:use-module ((srfi srfi-1) #:prefix srfi-1:)
|
||||||
#:use-module (srfi srfi-11)
|
#:use-module (srfi srfi-11)
|
||||||
#:use-module (srfi srfi-26)
|
#:use-module (srfi srfi-26)
|
||||||
#:use-module (srfi srfi-35)
|
#:use-module (srfi srfi-35)
|
||||||
#:use-module (rnrs bytevectors)
|
#:use-module (rnrs bytevectors)
|
||||||
|
#:use-module (ice-9 format)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
#:export (root-offset
|
#:export (root-offset
|
||||||
root-label
|
root-label
|
||||||
|
@ -207,8 +209,8 @@ (define (image->genimage-cfg image)
|
||||||
(define (format->image-type format)
|
(define (format->image-type format)
|
||||||
;; Return the genimage format corresponding to FORMAT. For now, only
|
;; Return the genimage format corresponding to FORMAT. For now, only
|
||||||
;; the hdimage format (raw disk-image) is supported.
|
;; the hdimage format (raw disk-image) is supported.
|
||||||
(case format
|
(cond
|
||||||
((disk-image) "hdimage")
|
((memq format '(disk-image compressed-qcow2)) "hdimage")
|
||||||
(else
|
(else
|
||||||
(raise (condition
|
(raise (condition
|
||||||
(&message
|
(&message
|
||||||
|
@ -306,25 +308,24 @@ (define (partition->config partition)
|
||||||
(name (if image-name
|
(name (if image-name
|
||||||
(symbol->string image-name)
|
(symbol->string image-name)
|
||||||
name))
|
name))
|
||||||
|
(format (image-format image))
|
||||||
(substitutable? (image-substitutable? image))
|
(substitutable? (image-substitutable? image))
|
||||||
(builder
|
(builder
|
||||||
(with-imported-modules*
|
(with-imported-modules*
|
||||||
(let ((inputs '#+(list genimage coreutils findutils))
|
(let ((inputs '#+(list genimage coreutils findutils qemu-minimal))
|
||||||
(bootloader-installer
|
(bootloader-installer
|
||||||
#+(bootloader-disk-image-installer bootloader)))
|
#+(bootloader-disk-image-installer bootloader))
|
||||||
|
(out-image (string-append "images/" #$genimage-name)))
|
||||||
(set-path-environment-variable "PATH" '("bin" "sbin") inputs)
|
(set-path-environment-variable "PATH" '("bin" "sbin") inputs)
|
||||||
(genimage #$(image->genimage-cfg image) #$output)
|
(genimage #$(image->genimage-cfg image))
|
||||||
;; Install the bootloader directly on the disk-image.
|
;; Install the bootloader directly on the disk-image.
|
||||||
(when bootloader-installer
|
(when bootloader-installer
|
||||||
(bootloader-installer
|
(bootloader-installer
|
||||||
#+(bootloader-package bootloader)
|
#+(bootloader-package bootloader)
|
||||||
#$(root-partition-index image)
|
#$(root-partition-index image)
|
||||||
(string-append #$output "/" #$genimage-name))))))
|
out-image))
|
||||||
(image-dir (computed-file "image-dir" builder)))
|
(convert-disk-image out-image '#$format #$output)))))
|
||||||
(computed-file name
|
(computed-file name builder
|
||||||
#~(symlink
|
|
||||||
(string-append #$image-dir "/" #$genimage-name)
|
|
||||||
#$output)
|
|
||||||
#:options `(#:substitutable? ,substitutable?))))
|
#:options `(#:substitutable? ,substitutable?))))
|
||||||
|
|
||||||
|
|
||||||
|
@ -523,19 +524,20 @@ (define target (image-target image))
|
||||||
(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))
|
||||||
(register-closures? (has-guix-service-type? os))
|
(register-closures? (has-guix-service-type? os))
|
||||||
(bootcfg (operating-system-bootcfg os))
|
(bootcfg (operating-system-bootcfg os))
|
||||||
(bootloader (bootloader-configuration-bootloader
|
(bootloader (bootloader-configuration-bootloader
|
||||||
(operating-system-bootloader os))))
|
(operating-system-bootloader os))))
|
||||||
(case (image-format image)
|
(cond
|
||||||
((disk-image)
|
((memq image-format '(disk-image compressed-qcow2))
|
||||||
(system-disk-image image*
|
(system-disk-image image*
|
||||||
#:bootcfg bootcfg
|
#:bootcfg bootcfg
|
||||||
#:bootloader bootloader
|
#:bootloader bootloader
|
||||||
#:register-closures? register-closures?
|
#:register-closures? register-closures?
|
||||||
#:inputs `(("system" ,os)
|
#:inputs `(("system" ,os)
|
||||||
("bootcfg" ,bootcfg))))
|
("bootcfg" ,bootcfg))))
|
||||||
((iso9660)
|
((memq image-format '(iso9660))
|
||||||
(system-iso9660-image
|
(system-iso9660-image
|
||||||
image*
|
image*
|
||||||
#:bootcfg bootcfg
|
#:bootcfg bootcfg
|
||||||
|
|
Loading…
Reference in a new issue