summaryrefslogtreecommitdiff
path: root/guix/build
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-04-11 18:44:53 +0200
committerLudovic Courtès <ludo@gnu.org>2014-04-11 19:08:25 +0200
commit55651ff20740037ddeb29ffe9d93097935bd023b (patch)
tree6e97a0baaabbc70933b79d7d4dc2171a559df64c /guix/build
parentade5ce7abcbf2a748f2afb02b6837c770281ca70 (diff)
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')
-rw-r--r--guix/build/vm.scm139
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