summaryrefslogtreecommitdiff
path: root/gnu
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 /gnu
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 'gnu')
-rw-r--r--gnu/system/vm.scm163
1 files changed, 15 insertions, 148 deletions
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index b0fd3f5710..069ac3093a 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -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))
-
- (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))
-
- (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))))))))
+ (use-modules (guix build vm)
+ (guix build utils))
+
+ (set-path-environment-variable "PATH" '("bin" "sbin")
+ (map cdr %build-inputs))
+
+ (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)