diff options
| -rw-r--r-- | gnu/system/vm.scm | 163 | ||||
| -rw-r--r-- | guix/build/vm.scm | 139 |
2 files changed, 152 insertions, 150 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) 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 |