summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gnu/system/vm.scm163
-rw-r--r--guix/build/vm.scm139
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
generated by cgit v1.2.3 (git 2.45.2) at 2024-07-03 23:01:10 +0000