diff options
author | Ludovic Courtès <ludo@gnu.org> | 2014-04-11 18:44:53 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2014-04-11 19:08:25 +0200 |
commit | 55651ff20740037ddeb29ffe9d93097935bd023b (patch) | |
tree | 6e97a0baaabbc70933b79d7d4dc2171a559df64c /guix/build/vm.scm | |
parent | ade5ce7abcbf2a748f2afb02b6837c770281ca70 (diff) | |
download | guix-patches-55651ff20740037ddeb29ffe9d93097935bd023b.tar guix-patches-55651ff20740037ddeb29ffe9d93097935bd023b.tar.gz |
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'.
Diffstat (limited to 'guix/build/vm.scm')
-rw-r--r-- | guix/build/vm.scm | 139 |
1 files changed, 137 insertions, 2 deletions
diff --git a/guix/build/vm.scm b/guix/build/vm.scm index 725ede4e1f..33c898d968 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -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 |