vm: Move image creation to (guix build vm); split into several procedures.
* guix/build/vm.scm (read-reference-graph, initialize-partition-table, install-grub, populate-store, evaluate-populate-directive, reset-timestamps, initialize-hard-disk): New procedures. * gnu/system/vm.scm (qemu-image): Change 'builder' to a call to 'initialize-hard-disk'.
This commit is contained in:
Ludovic Courtès
parent
ade5ce7abc
commit
55651ff207
|
|
@ -217,154 +217,21 @@ such as /etc files."
|
||||||
(expression->derivation-in-linux-vm
|
(expression->derivation-in-linux-vm
|
||||||
"qemu-image"
|
"qemu-image"
|
||||||
`(let ()
|
`(let ()
|
||||||
(use-modules (ice-9 rdelim)
|
(use-modules (guix build vm)
|
||||||
(srfi srfi-1)
|
(guix build utils))
|
||||||
(guix build utils)
|
|
||||||
(guix build linux-initrd))
|
|
||||||
|
|
||||||
(let ((parted (string-append (assoc-ref %build-inputs "parted")
|
(set-path-environment-variable "PATH" '("bin" "sbin")
|
||||||
"/sbin/parted"))
|
(map cdr %build-inputs))
|
||||||
(mkfs (string-append (assoc-ref %build-inputs "e2fsprogs")
|
|
||||||
"/sbin/mkfs.ext3"))
|
|
||||||
(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
|
|
||||||
(grub.cfg ,grub-configuration))
|
|
||||||
|
|
||||||
(define (read-reference-graph port)
|
(let ((graphs ',(match inputs-to-copy
|
||||||
;; Return a list of store paths from the reference graph at PORT.
|
(((names . _) ...)
|
||||||
;; The data at PORT is the format produced by #:references-graphs.
|
names))))
|
||||||
(let loop ((line (read-line port))
|
(initialize-hard-disk #:grub.cfg ,grub-configuration
|
||||||
(result '()))
|
#:closures-to-copy graphs
|
||||||
(cond ((eof-object? line)
|
#:disk-image-size ,disk-image-size
|
||||||
(delete-duplicates result))
|
#:initialize-store? ,initialize-store?
|
||||||
((string-prefix? "/" line)
|
#:directives ',populate)
|
||||||
(loop (read-line port)
|
(reboot)))
|
||||||
(cons line result)))
|
|
||||||
(else
|
|
||||||
(loop (read-line port)
|
|
||||||
result)))))
|
|
||||||
|
|
||||||
(define (things-to-copy)
|
|
||||||
;; Return the list of store files to copy to the image.
|
|
||||||
(define (graph-from-file file)
|
|
||||||
(call-with-input-file file
|
|
||||||
read-reference-graph))
|
|
||||||
|
|
||||||
,(match inputs-to-copy
|
|
||||||
(((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")
|
|
||||||
(and (zero? (system* parted "/dev/sda" "mklabel" "msdos"
|
|
||||||
"mkpart" "primary" "ext2" "1MiB"
|
|
||||||
,(format #f "~aB"
|
|
||||||
(- disk-image-size
|
|
||||||
(* 5 (expt 2 20))))))
|
|
||||||
(begin
|
|
||||||
(display "creating ext3 partition...\n")
|
|
||||||
(and (zero? (system* mkfs "-F" "/dev/sda1"))
|
|
||||||
(let ((store (string-append "/fs" ,(%store-prefix))))
|
|
||||||
(display "mounting partition...\n")
|
|
||||||
(mkdir "/fs")
|
|
||||||
(mount "/dev/sda1" "/fs" "ext3")
|
|
||||||
(mkdir-p "/fs/boot/grub")
|
|
||||||
(symlink grub.cfg "/fs/boot/grub/grub.cfg")
|
|
||||||
|
|
||||||
;; Populate the image's store.
|
|
||||||
(mkdir-p store)
|
|
||||||
(chmod store #o1775)
|
|
||||||
(for-each (lambda (thing)
|
|
||||||
(copy-recursively thing
|
|
||||||
(string-append "/fs"
|
|
||||||
thing)))
|
|
||||||
(things-to-copy))
|
|
||||||
|
|
||||||
;; Populate /dev.
|
|
||||||
(make-essential-device-nodes #:root "/fs")
|
|
||||||
|
|
||||||
;; Optionally, register the inputs in the image's store.
|
|
||||||
(let* ((guix (assoc-ref %build-inputs "guix"))
|
|
||||||
(register (and guix
|
|
||||||
(string-append guix
|
|
||||||
"/sbin/guix-register"))))
|
|
||||||
,@(if initialize-store?
|
|
||||||
(match inputs-to-copy
|
|
||||||
(((graph-files . _) ...)
|
|
||||||
(map (lambda (closure)
|
|
||||||
`(system* register "--prefix" "/fs"
|
|
||||||
,(string-append "/xchg/"
|
|
||||||
closure)))
|
|
||||||
graph-files)))
|
|
||||||
'(#f)))
|
|
||||||
|
|
||||||
;; Evaluate the POPULATE directives.
|
|
||||||
,@(let loop ((directives populate)
|
|
||||||
(statements '()))
|
|
||||||
(match directives
|
|
||||||
(()
|
|
||||||
(reverse statements))
|
|
||||||
((('directory name) rest ...)
|
|
||||||
(loop rest
|
|
||||||
(cons `(mkdir-p ,(string-append "/fs" name))
|
|
||||||
statements)))
|
|
||||||
((('directory name uid gid) rest ...)
|
|
||||||
(let ((dir (string-append "/fs" name)))
|
|
||||||
(loop rest
|
|
||||||
(cons* `(chown ,dir ,uid ,gid)
|
|
||||||
`(mkdir-p ,dir)
|
|
||||||
statements))))
|
|
||||||
(((new '-> old) rest ...)
|
|
||||||
(loop rest
|
|
||||||
(cons `(symlink ,old
|
|
||||||
,(string-append "/fs" new))
|
|
||||||
statements)))))
|
|
||||||
|
|
||||||
(and=> (assoc-ref %build-inputs "populate")
|
|
||||||
(lambda (populate)
|
|
||||||
(chdir "/fs")
|
|
||||||
(primitive-load populate)
|
|
||||||
(chdir "/")))
|
|
||||||
|
|
||||||
(display "clearing file timestamps...\n")
|
|
||||||
(for-each (lambda (file)
|
|
||||||
(let ((s (lstat file)))
|
|
||||||
;; XXX: Guile uses libc's 'utime' function
|
|
||||||
;; (not 'futime'), so the timestamp of
|
|
||||||
;; symlinks cannot be changed, and there
|
|
||||||
;; are symlinks here pointing to
|
|
||||||
;; /gnu/store, which is the host,
|
|
||||||
;; read-only store.
|
|
||||||
(unless (eq? (stat:type s) 'symlink)
|
|
||||||
(utime file 0 0 0 0))))
|
|
||||||
(find-files "/fs" ".*"))
|
|
||||||
|
|
||||||
(and (zero?
|
|
||||||
(system* grub "--no-floppy"
|
|
||||||
"--boot-directory" "/fs/boot"
|
|
||||||
"/dev/sda"))
|
|
||||||
(begin
|
|
||||||
(when (file-exists? "/fs/dev/pts")
|
|
||||||
;; Unmount devpts so /fs itself can be
|
|
||||||
;; unmounted (failing to do that leads to
|
|
||||||
;; EBUSY.)
|
|
||||||
(system* umount "/fs/dev/pts"))
|
|
||||||
(zero? (system* umount "/fs")))
|
|
||||||
(reboot))))))))
|
|
||||||
#:system system
|
#:system system
|
||||||
#:inputs `(("parted" ,parted)
|
#:inputs `(("parted" ,parted)
|
||||||
("grub" ,grub)
|
("grub" ,grub)
|
||||||
|
|
|
||||||
|
|
@ -17,9 +17,14 @@
|
||||||
;;; 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 (guix build vm)
|
(define-module (guix build vm)
|
||||||
#:use-module (ice-9 match)
|
|
||||||
#:use-module (guix build utils)
|
#:use-module (guix build utils)
|
||||||
#:export (load-in-linux-vm))
|
#:use-module (guix build linux-initrd)
|
||||||
|
#:use-module (ice-9 match)
|
||||||
|
#:use-module (ice-9 rdelim)
|
||||||
|
#:use-module (srfi srfi-1)
|
||||||
|
#:use-module (srfi srfi-26)
|
||||||
|
#:export (load-in-linux-vm
|
||||||
|
initialize-hard-disk))
|
||||||
|
|
||||||
;;; Commentary:
|
;;; Commentary:
|
||||||
;;;
|
;;;
|
||||||
|
|
@ -94,4 +99,134 @@ the #:references-graphs parameter of 'derivation'."
|
||||||
(mkdir output)
|
(mkdir output)
|
||||||
(copy-recursively "xchg" output))))
|
(copy-recursively "xchg" output))))
|
||||||
|
|
||||||
|
(define (read-reference-graph port)
|
||||||
|
"Return a list of store paths from the reference graph at PORT.
|
||||||
|
The data at PORT is the format produced by #:references-graphs."
|
||||||
|
(let loop ((line (read-line port))
|
||||||
|
(result '()))
|
||||||
|
(cond ((eof-object? line)
|
||||||
|
(delete-duplicates result))
|
||||||
|
((string-prefix? "/" line)
|
||||||
|
(loop (read-line port)
|
||||||
|
(cons line result)))
|
||||||
|
(else
|
||||||
|
(loop (read-line port)
|
||||||
|
result)))))
|
||||||
|
|
||||||
|
(define* (initialize-partition-table device
|
||||||
|
#:key
|
||||||
|
(label-type "msdos")
|
||||||
|
partition-size)
|
||||||
|
"Create on DEVICE a partition table of type LABEL-TYPE, with a single
|
||||||
|
partition of PARTITION-SIZE MiB. Return #t on success."
|
||||||
|
(display "creating partition table...\n")
|
||||||
|
(zero? (system* "parted" "/dev/sda" "mklabel" label-type
|
||||||
|
"mkpart" "primary" "ext2" "1MiB"
|
||||||
|
(format #f "~aB" partition-size))))
|
||||||
|
|
||||||
|
(define* (install-grub grub.cfg device mount-point)
|
||||||
|
"Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on
|
||||||
|
MOUNT-POINT. Return #t on success."
|
||||||
|
(mkdir-p (string-append mount-point "/boot/grub"))
|
||||||
|
(symlink grub.cfg (string-append mount-point "/boot/grub/grub.cfg"))
|
||||||
|
(zero? (system* "grub-install" "--no-floppy"
|
||||||
|
"--boot-directory" (string-append mount-point "/boot")
|
||||||
|
device)))
|
||||||
|
|
||||||
|
(define* (populate-store reference-graphs target)
|
||||||
|
"Populate the store under directory TARGET with the items specified in
|
||||||
|
REFERENCE-GRAPHS, a list of reference-graph files."
|
||||||
|
(define store
|
||||||
|
(string-append target (%store-directory)))
|
||||||
|
|
||||||
|
(define (things-to-copy)
|
||||||
|
;; Return the list of store files to copy to the image.
|
||||||
|
(define (graph-from-file file)
|
||||||
|
(call-with-input-file file read-reference-graph))
|
||||||
|
|
||||||
|
(delete-duplicates (append-map graph-from-file reference-graphs)))
|
||||||
|
|
||||||
|
(mkdir-p store)
|
||||||
|
(chmod store #o1775)
|
||||||
|
(for-each (lambda (thing)
|
||||||
|
(copy-recursively thing
|
||||||
|
(string-append target thing)))
|
||||||
|
(things-to-copy)))
|
||||||
|
|
||||||
|
(define (evaluate-populate-directive directive target)
|
||||||
|
"Evaluate DIRECTIVE, an sexp describing a file or directory to create under
|
||||||
|
directory TARGET."
|
||||||
|
(match directive
|
||||||
|
(('directory name)
|
||||||
|
(mkdir-p (string-append target name)))
|
||||||
|
(('directory name uid gid)
|
||||||
|
(let ((dir (string-append target name)))
|
||||||
|
(mkdir-p dir)
|
||||||
|
(chown dir uid gid)))
|
||||||
|
((new '-> old)
|
||||||
|
(symlink old (string-append target new)))))
|
||||||
|
|
||||||
|
(define (reset-timestamps directory)
|
||||||
|
"Reset the timestamps of all the files under DIRECTORY, so that they appear
|
||||||
|
as created and modified at the Epoch."
|
||||||
|
(display "clearing file timestamps...\n")
|
||||||
|
(for-each (lambda (file)
|
||||||
|
(let ((s (lstat file)))
|
||||||
|
;; XXX: Guile uses libc's 'utime' function (not 'futime'), so
|
||||||
|
;; the timestamp of symlinks cannot be changed, and there are
|
||||||
|
;; symlinks here pointing to /gnu/store, which is the host,
|
||||||
|
;; read-only store.
|
||||||
|
(unless (eq? (stat:type s) 'symlink)
|
||||||
|
(utime file 0 0 0 0))))
|
||||||
|
(find-files directory "")))
|
||||||
|
|
||||||
|
(define* (initialize-hard-disk #:key
|
||||||
|
grub.cfg
|
||||||
|
disk-image-size
|
||||||
|
(mkfs "mkfs.ext3")
|
||||||
|
initialize-store?
|
||||||
|
(closures-to-copy '())
|
||||||
|
(directives '()))
|
||||||
|
(unless (initialize-partition-table "/dev/sda"
|
||||||
|
#:partition-size
|
||||||
|
(- disk-image-size (* 5 (expt 2 20))))
|
||||||
|
(error "failed to create partition table"))
|
||||||
|
|
||||||
|
(display "creating ext3 partition...\n")
|
||||||
|
(unless (zero? (system* mkfs "-F" "/dev/sda1"))
|
||||||
|
(error "failed to create partition"))
|
||||||
|
|
||||||
|
(display "mounting partition...\n")
|
||||||
|
(mkdir "/fs")
|
||||||
|
(mount "/dev/sda1" "/fs" "ext3")
|
||||||
|
|
||||||
|
(when (pair? closures-to-copy)
|
||||||
|
;; Populate the store.
|
||||||
|
(populate-store (map (cut string-append "/xchg/" <>)
|
||||||
|
closures-to-copy)
|
||||||
|
"/fs"))
|
||||||
|
|
||||||
|
;; Populate /dev.
|
||||||
|
(make-essential-device-nodes #:root "/fs")
|
||||||
|
|
||||||
|
;; Optionally, register the inputs in the image's store.
|
||||||
|
(when initialize-store?
|
||||||
|
(for-each (lambda (closure)
|
||||||
|
(let ((status (system* "guix-register" "--prefix" "/fs"
|
||||||
|
(string-append "/xchg/" closure))))
|
||||||
|
(unless (zero? status)
|
||||||
|
(error "failed to register store items" closure))))
|
||||||
|
closures-to-copy))
|
||||||
|
|
||||||
|
;; Evaluate the POPULATE directives.
|
||||||
|
(for-each (cut evaluate-populate-directive <> "/fs")
|
||||||
|
directives)
|
||||||
|
|
||||||
|
(unless (install-grub grub.cfg "/dev/sda" "/fs")
|
||||||
|
(error "failed to install GRUB"))
|
||||||
|
|
||||||
|
(reset-timestamps "/fs")
|
||||||
|
|
||||||
|
(zero? (system* "umount" "/fs")))
|
||||||
|
|
||||||
;;; vm.scm ends here
|
;;; vm.scm ends here
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue