gnu: vm: `qemu-image' can copy store closures into the target image.
* gnu/system/vm.scm (qemu-image): Add #:inputs-to-copy and #:boot-expression parameters. Honor them. Append INPUTS-TO-COPY to the #:inputs argument for `expression->derivation-in-linux-vm'. (example2): Add #:boot-expression and #:inputs-to-copy arguments.
This commit is contained in:
Ludovic Courtès
parent
4c0f0673b2
commit
93d44bd8de
|
|
@ -17,6 +17,7 @@
|
||||||
;;; 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 vm)
|
(define-module (gnu system vm)
|
||||||
|
#:use-module (guix config)
|
||||||
#:use-module (guix store)
|
#:use-module (guix store)
|
||||||
#:use-module (guix derivations)
|
#:use-module (guix derivations)
|
||||||
#:use-module (guix packages)
|
#:use-module (guix packages)
|
||||||
|
|
@ -28,6 +29,8 @@
|
||||||
#:use-module (gnu packages linux-initrd)
|
#:use-module (gnu packages linux-initrd)
|
||||||
#:use-module ((gnu packages make-bootstrap)
|
#:use-module ((gnu packages make-bootstrap)
|
||||||
#:select (%guile-static-stripped))
|
#:select (%guile-static-stripped))
|
||||||
|
#:use-module ((gnu packages system)
|
||||||
|
#:select (shadow))
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-26)
|
#:use-module (srfi srfi-26)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
|
|
@ -175,77 +178,150 @@ made available under the /xchg CIFS share."
|
||||||
(disk-image-size (* 100 (expt 2 20)))
|
(disk-image-size (* 100 (expt 2 20)))
|
||||||
(linux linux-libre)
|
(linux linux-libre)
|
||||||
(initrd qemu-initrd)
|
(initrd qemu-initrd)
|
||||||
(inputs '()))
|
(inputs '())
|
||||||
"Return a bootable, stand-alone QEMU image."
|
(inputs-to-copy '())
|
||||||
|
(boot-expression #f))
|
||||||
|
"Return a bootable, stand-alone QEMU image.
|
||||||
|
|
||||||
|
INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied
|
||||||
|
into the image being built.
|
||||||
|
|
||||||
|
When BOOT-EXPRESSION is true, it is an expression to evaluate when the basic
|
||||||
|
initialization is done. A typical example is `(execl ...)' to launch the init
|
||||||
|
process."
|
||||||
|
(define input->name+derivation
|
||||||
|
(match-lambda
|
||||||
|
((name (? package? package))
|
||||||
|
`(,name . ,(derivation-path->output-path
|
||||||
|
(package-derivation store package system))))
|
||||||
|
((name (? package? package) sub-drv)
|
||||||
|
`(,name . ,(derivation-path->output-path
|
||||||
|
(package-derivation store package system)
|
||||||
|
sub-drv)))))
|
||||||
|
|
||||||
|
(define loader
|
||||||
|
(and boot-expression
|
||||||
|
(add-text-to-store store "loader"
|
||||||
|
(object->string boot-expression)
|
||||||
|
'())))
|
||||||
|
|
||||||
(expression->derivation-in-linux-vm
|
(expression->derivation-in-linux-vm
|
||||||
store "qemu-image"
|
store "qemu-image"
|
||||||
`(let ((parted (string-append (assoc-ref %build-inputs "parted")
|
`(let ()
|
||||||
"/sbin/parted"))
|
(use-modules (ice-9 rdelim)
|
||||||
(mkfs (string-append (assoc-ref %build-inputs "e2fsprogs")
|
(srfi srfi-1)
|
||||||
"/sbin/mkfs.ext3"))
|
(guix build utils))
|
||||||
(grub (string-append (assoc-ref %build-inputs "grub")
|
|
||||||
"/sbin/grub-install"))
|
|
||||||
(umount (string-append (assoc-ref %build-inputs "util-linux")
|
|
||||||
"/bin/umount")) ; XXX: add to Guile
|
|
||||||
(initrd (string-append (assoc-ref %build-inputs "initrd")
|
|
||||||
"/initrd"))
|
|
||||||
(linux (string-append (assoc-ref %build-inputs "linux")
|
|
||||||
"/bzImage"))
|
|
||||||
(makedev (lambda (major minor)
|
|
||||||
(+ (* major 256) minor))))
|
|
||||||
|
|
||||||
;; GRUB is full of shell scripts.
|
(let ((parted (string-append (assoc-ref %build-inputs "parted")
|
||||||
(setenv "PATH"
|
"/sbin/parted"))
|
||||||
(string-append (dirname grub) ":"
|
(mkfs (string-append (assoc-ref %build-inputs "e2fsprogs")
|
||||||
(assoc-ref %build-inputs "coreutils") "/bin:"
|
"/sbin/mkfs.ext3"))
|
||||||
(assoc-ref %build-inputs "findutils") "/bin:"
|
(grub (string-append (assoc-ref %build-inputs "grub")
|
||||||
(assoc-ref %build-inputs "sed") "/bin:"
|
"/sbin/grub-install"))
|
||||||
(assoc-ref %build-inputs "grep") "/bin:"
|
(umount (string-append (assoc-ref %build-inputs "util-linux")
|
||||||
(assoc-ref %build-inputs "gawk") "/bin"))
|
"/bin/umount")) ; XXX: add to Guile
|
||||||
|
(initrd (string-append (assoc-ref %build-inputs "initrd")
|
||||||
|
"/initrd"))
|
||||||
|
(linux (string-append (assoc-ref %build-inputs "linux")
|
||||||
|
"/bzImage"))
|
||||||
|
(makedev (lambda (major minor)
|
||||||
|
(+ (* major 256) minor))))
|
||||||
|
|
||||||
(display "creating partition table...\n")
|
(define (read-reference-graph port)
|
||||||
(mknod "/dev/vda" 'block-special #o644 (makedev 8 0))
|
;; Return a list of store paths from the reference graph at PORT.
|
||||||
(and (zero? (system* parted "/dev/vda" "mklabel" "msdos"
|
;; The data at PORT is the format produced by #:references-graphs.
|
||||||
"mkpart" "primary" "ext2" "1MiB"
|
(let loop ((line (read-line port))
|
||||||
,(format #f "~aB"
|
(result '()))
|
||||||
(- disk-image-size
|
(cond ((eof-object? line)
|
||||||
(* 5 (expt 2 20))))))
|
(delete-duplicates result))
|
||||||
(begin
|
((string-prefix? "/" line)
|
||||||
(display "creating ext3 partition...\n")
|
(loop (read-line port)
|
||||||
(mknod "/dev/vda1" 'block-special #o644 (makedev 8 1))
|
(cons line result)))
|
||||||
(and (zero? (system* mkfs "-F" "/dev/vda1"))
|
(else
|
||||||
(begin
|
(loop (read-line port)
|
||||||
(display "mounting partition...\n")
|
result)))))
|
||||||
(mkdir "/fs")
|
|
||||||
(mount "/dev/vda1" "/fs" "ext3")
|
(define (things-to-copy)
|
||||||
(mkdir "/fs/boot")
|
;; Return the list of store files to copy to the image.
|
||||||
(mkdir "/fs/boot/grub")
|
(define (graph-from-file file)
|
||||||
(copy-file linux "/fs/boot/bzImage")
|
(call-with-input-file file
|
||||||
(copy-file initrd "/fs/boot/initrd")
|
read-reference-graph))
|
||||||
(call-with-output-file "/fs/boot/grub/grub.cfg"
|
|
||||||
(lambda (p)
|
,(match inputs-to-copy
|
||||||
(display "
|
(((graph-files . _) ...)
|
||||||
|
`(let* ((graph-files ',(map (cut string-append "/xchg/" <>)
|
||||||
|
graph-files))
|
||||||
|
(paths (append-map graph-from-file graph-files)))
|
||||||
|
(delete-duplicates paths)))
|
||||||
|
(#f ''())))
|
||||||
|
|
||||||
|
;; GRUB is full of shell scripts.
|
||||||
|
(setenv "PATH"
|
||||||
|
(string-append (dirname grub) ":"
|
||||||
|
(assoc-ref %build-inputs "coreutils") "/bin:"
|
||||||
|
(assoc-ref %build-inputs "findutils") "/bin:"
|
||||||
|
(assoc-ref %build-inputs "sed") "/bin:"
|
||||||
|
(assoc-ref %build-inputs "grep") "/bin:"
|
||||||
|
(assoc-ref %build-inputs "gawk") "/bin"))
|
||||||
|
|
||||||
|
(display "creating partition table...\n")
|
||||||
|
(mknod "/dev/vda" 'block-special #o644 (makedev 8 0))
|
||||||
|
(and (zero? (system* parted "/dev/vda" "mklabel" "msdos"
|
||||||
|
"mkpart" "primary" "ext2" "1MiB"
|
||||||
|
,(format #f "~aB"
|
||||||
|
(- disk-image-size
|
||||||
|
(* 5 (expt 2 20))))))
|
||||||
|
(begin
|
||||||
|
(display "creating ext3 partition...\n")
|
||||||
|
(mknod "/dev/vda1" 'block-special #o644 (makedev 8 1))
|
||||||
|
(and (zero? (system* mkfs "-F" "/dev/vda1"))
|
||||||
|
(begin
|
||||||
|
(display "mounting partition...\n")
|
||||||
|
(mkdir "/fs")
|
||||||
|
(mount "/dev/vda1" "/fs" "ext3")
|
||||||
|
(mkdir-p "/fs/boot/grub")
|
||||||
|
(copy-file linux "/fs/boot/bzImage")
|
||||||
|
(copy-file initrd "/fs/boot/initrd")
|
||||||
|
|
||||||
|
;; Populate the image's store.
|
||||||
|
(mkdir-p (string-append "/fs" ,%store-directory))
|
||||||
|
(for-each (lambda (thing)
|
||||||
|
(copy-recursively thing
|
||||||
|
(string-append "/fs"
|
||||||
|
thing)))
|
||||||
|
(things-to-copy))
|
||||||
|
|
||||||
|
(call-with-output-file "/fs/boot/grub/grub.cfg"
|
||||||
|
(lambda (p)
|
||||||
|
(format p "
|
||||||
set default=1
|
set default=1
|
||||||
set timeout=5
|
set timeout=5
|
||||||
search.file /boot/bzImage
|
search.file /boot/bzImage
|
||||||
|
|
||||||
menuentry \"Boot-to-Guile! (GNU System technology preview)\" {
|
menuentry \"Boot-to-Guile! (GNU System technology preview)\" {
|
||||||
linux /boot/bzImage --repl
|
linux /boot/bzImage --root=/dev/vda1 ~a
|
||||||
initrd /boot/initrd
|
initrd /boot/initrd
|
||||||
}" p)))
|
}"
|
||||||
(and (zero?
|
,(if loader
|
||||||
(system* grub "--no-floppy"
|
(string-append "--load=" loader)
|
||||||
"--boot-directory" "/fs/boot"
|
""))))
|
||||||
"/dev/vda"))
|
(and (zero?
|
||||||
(zero?
|
(system* grub "--no-floppy"
|
||||||
(system* umount "/fs"))
|
"--boot-directory" "/fs/boot"
|
||||||
(reboot)))))))
|
"/dev/vda"))
|
||||||
|
(zero?
|
||||||
|
(system* umount "/fs"))
|
||||||
|
(reboot))))))))
|
||||||
#:system system
|
#:system system
|
||||||
#:inputs `(("parted" ,parted)
|
#:inputs `(("parted" ,parted)
|
||||||
("grub" ,grub)
|
("grub" ,grub)
|
||||||
("e2fsprogs" ,e2fsprogs)
|
("e2fsprogs" ,e2fsprogs)
|
||||||
("linux" ,linux-libre)
|
("linux" ,linux-libre)
|
||||||
("initrd" ,qemu-initrd)
|
("initrd" ,initrd)
|
||||||
|
|
||||||
|
,@(if loader
|
||||||
|
`(("loader" ,loader))
|
||||||
|
'())
|
||||||
|
|
||||||
;; For shell scripts.
|
;; For shell scripts.
|
||||||
("sed" ,(car (assoc-ref %final-inputs "sed")))
|
("sed" ,(car (assoc-ref %final-inputs "sed")))
|
||||||
|
|
@ -253,9 +329,13 @@ menuentry \"Boot-to-Guile! (GNU System technology preview)\" {
|
||||||
("coreutils" ,(car (assoc-ref %final-inputs "coreutils")))
|
("coreutils" ,(car (assoc-ref %final-inputs "coreutils")))
|
||||||
("findutils" ,(car (assoc-ref %final-inputs "findutils")))
|
("findutils" ,(car (assoc-ref %final-inputs "findutils")))
|
||||||
("gawk" ,(car (assoc-ref %final-inputs "gawk")))
|
("gawk" ,(car (assoc-ref %final-inputs "gawk")))
|
||||||
("util-linux" ,util-linux))
|
("util-linux" ,util-linux)
|
||||||
|
|
||||||
|
,@inputs-to-copy)
|
||||||
#:make-disk-image? #t
|
#:make-disk-image? #t
|
||||||
#:disk-image-size disk-image-size))
|
#:disk-image-size disk-image-size
|
||||||
|
#:references-graphs (map input->name+derivation inputs-to-copy)
|
||||||
|
#:modules '((guix build utils))))
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
|
|
@ -286,7 +366,13 @@ menuentry \"Boot-to-Guile! (GNU System technology preview)\" {
|
||||||
(set! store (open-connection)))
|
(set! store (open-connection)))
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(parameterize ((%guile-for-build (package-derivation store guile-final)))
|
(parameterize ((%guile-for-build (package-derivation store guile-final)))
|
||||||
(qemu-image store #:disk-image-size (* 30 (expt 2 20)))))
|
(let* ((drv (package-derivation store shadow))
|
||||||
|
(login (string-append (derivation-path->output-path drv)
|
||||||
|
"/bin/login")))
|
||||||
|
(qemu-image store
|
||||||
|
#:boot-expression `(execl ,login "login" "tty1")
|
||||||
|
#:disk-image-size (* 400 (expt 2 20))
|
||||||
|
#:inputs-to-copy `(("shadow" ,shadow))))))
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(close-connection store)))))
|
(close-connection store)))))
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue