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'.master
Ludovic Courtès
parent
ade5ce7abc
commit
55651ff207
|
|
@ -217,154 +217,21 @@ such as /etc files."
|
|||
(expression->derivation-in-linux-vm
|
||||
"qemu-image"
|
||||
`(let ()
|
||||
(use-modules (ice-9 rdelim)
|
||||
(srfi srfi-1)
|
||||
(guix build utils)
|
||||
(guix build linux-initrd))
|
||||
(use-modules (guix build vm)
|
||||
(guix build utils))
|
||||
|
||||
(let ((parted (string-append (assoc-ref %build-inputs "parted")
|
||||
"/sbin/parted"))
|
||||
(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))
|
||||
(set-path-environment-variable "PATH" '("bin" "sbin")
|
||||
(map cdr %build-inputs))
|
||||
|
||||
(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 (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))))))))
|
||||
(let ((graphs ',(match inputs-to-copy
|
||||
(((names . _) ...)
|
||||
names))))
|
||||
(initialize-hard-disk #:grub.cfg ,grub-configuration
|
||||
#:closures-to-copy graphs
|
||||
#:disk-image-size ,disk-image-size
|
||||
#:initialize-store? ,initialize-store?
|
||||
#:directives ',populate)
|
||||
(reboot)))
|
||||
#:system system
|
||||
#:inputs `(("parted" ,parted)
|
||||
("grub" ,grub)
|
||||
|
|
|
|||
|
|
@ -17,9 +17,14 @@
|
|||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (guix build vm)
|
||||
#:use-module (ice-9 match)
|
||||
#: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:
|
||||
;;;
|
||||
|
|
@ -94,4 +99,134 @@ the #:references-graphs parameter of 'derivation'."
|
|||
(mkdir 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
|
||||
|
|
|
|||
Reference in New Issue