aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2015-07-25 23:57:52 +0200
committerLudovic Courtès <ludo@gnu.org>2015-07-26 00:57:44 +0200
commit72b891e50e1d0106a4b7a0fd88a44e34baae93e9 (patch)
tree8be1c181ffd8633be67995e2830506829a05ba9d
parent5b9da1f955a9c765191259eb9d24520e4b174e38 (diff)
downloadguix-72b891e50e1d0106a4b7a0fd88a44e34baae93e9.tar
guix-72b891e50e1d0106a4b7a0fd88a44e34baae93e9.tar.gz
vm: Make the list of partitions to build a parameter.
* gnu/build/vm.scm (<partition>): New record type. (fold2): New procedure. (initialize-partition-table): Remove #:bootable? and 'partition-size' parameters. Add 'partitions' parameter. Invoke 'parted' with '--script'. (initialize-root-partition): Remove. (initialize-partition, root-partition-initializer): New procedures. (initialize-hard-disk): Remove #:system-directory, #:disk-image-size, #:file-system-type, #:file-system-label, #:closures, #:copy-closures?, #:bootable?, and #:register-closures? parameters. Add #:partitions. Rewrite to use 'initialize-partition' for each item of PARTITIONS. * gnu/system/vm.scm (expression->derivation-in-linux-vm): Add (guix records) to #:modules default value. (qemu-image): Adjust accordingly.
-rw-r--r--gnu/build/vm.scm263
-rw-r--r--gnu/system/vm.scm29
2 files changed, 186 insertions, 106 deletions
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 15c22a3e55..a095f9de8a 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -21,13 +21,26 @@
#:use-module (guix build store-copy)
#:use-module (gnu build linux-boot)
#:use-module (gnu build install)
+ #:use-module (guix records)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:export (qemu-command
load-in-linux-vm
format-partition
- initialize-root-partition
+
+ partition
+ partition?
+ partition-device
+ partition-size
+ partition-file-system
+ partition-label
+ partition-bootable?
+ partition-initializer
+
+ root-partition-initializer
initialize-partition-table
initialize-hard-disk))
@@ -110,24 +123,84 @@ the #:references-graphs parameter of 'derivation'."
(mkdir output)
(copy-recursively "xchg" output))))
-(define* (initialize-partition-table device partition-size
+
+;;;
+;;; Partitions.
+;;;
+
+(define-record-type* <partition> partition make-partition
+ partition?
+ (device partition-device (default #f))
+ (size partition-size)
+ (file-system partition-file-system (default "ext4"))
+ (label partition-label (default #f))
+ (bootable? partition-bootable? (default #f))
+ (initializer partition-initializer (default (const #t))))
+
+(define (fold2 proc seed1 seed2 lst) ;TODO: factorize
+ "Like `fold', but with a single list and two seeds."
+ (let loop ((result1 seed1)
+ (result2 seed2)
+ (lst lst))
+ (if (null? lst)
+ (values result1 result2)
+ (call-with-values
+ (lambda () (proc (car lst) result1 result2))
+ (lambda (result1 result2)
+ (loop result1 result2 (cdr lst)))))))
+
+(define* (initialize-partition-table device partitions
#:key
- bootable?
(label-type "msdos")
(offset (expt 2 20)))
- "Create on DEVICE a partition table of type LABEL-TYPE, with a single
-partition of PARTITION-SIZE bytes starting at OFFSET bytes. When BOOTABLE? is
-true, set the bootable flag on the partition. Return #t on success."
- (format #t "creating partition table with a ~a B partition...\n"
- partition-size)
- (unless (zero? (apply system* "parted" device "mklabel" label-type
- "mkpart" "primary" "ext2"
- (format #f "~aB" offset)
- (format #f "~aB" partition-size)
- (if bootable?
- '("set" "1" "boot" "on")
- '())))
- (error "failed to create partition table")))
+ "Create on DEVICE a partition table of type LABEL-TYPE, containing the given
+PARTITIONS (a list of <partition> objects), starting at OFFSET bytes. On
+success, return PARTITIONS with their 'device' field changed to reflect their
+actual /dev name based on DEVICE."
+ (define (partition-options part offset index)
+ (cons* "mkpart" "primary" "ext2"
+ (format #f "~aB" offset)
+ (format #f "~aB" (+ offset (partition-size part)))
+ (if (partition-bootable? part)
+ `("set" ,(number->string index) "boot" "on")
+ '())))
+
+ (define (options partitions offset)
+ (let loop ((partitions partitions)
+ (offset offset)
+ (index 1)
+ (result '()))
+ (match partitions
+ (()
+ (concatenate (reverse result)))
+ ((head tail ...)
+ (loop tail
+ ;; Leave one sector (512B) between partitions to placate
+ ;; Parted.
+ (+ offset 512 (partition-size head))
+ (+ 1 index)
+ (cons (partition-options head offset index)
+ result))))))
+
+ (format #t "creating partition table with ~a partitions...\n"
+ (length partitions))
+ (unless (zero? (apply system* "parted" "--script"
+ device "mklabel" label-type
+ (options partitions offset)))
+ (error "failed to create partition table"))
+
+ ;; Set the 'device' field of each partition.
+ (reverse
+ (fold2 (lambda (part result index)
+ (values (cons (partition
+ (inherit part)
+ (device (string-append device
+ (number->string index))))
+ result)
+ (+ 1 index)))
+ '()
+ 1
+ partitions)))
(define MS_BIND 4096) ; <sys/mounts.h> again!
@@ -143,40 +216,67 @@ volume name."
'())))
(error "failed to create partition")))
-(define* (initialize-root-partition target-directory
- #:key copy-closures? register-closures?
- closures system-directory)
- "Initialize the root partition mounted at TARGET-DIRECTORY."
- (define target-store
- (string-append target-directory (%store-directory)))
-
- (when copy-closures?
- ;; Populate the store.
- (populate-store (map (cut string-append "/xchg/" <>) closures)
- target-directory))
-
- ;; Populate /dev.
- (make-essential-device-nodes #:root target-directory)
-
- ;; Optionally, register the inputs in the image's store.
- (when register-closures?
- (unless copy-closures?
- ;; XXX: 'guix-register' wants to palpate the things it registers, so
- ;; bind-mount the store on the target.
- (mkdir-p target-store)
- (mount (%store-directory) target-store "" MS_BIND))
-
- (display "registering closures...\n")
- (for-each (lambda (closure)
- (register-closure target-directory
- (string-append "/xchg/" closure)))
- closures)
- (unless copy-closures?
- (umount target-store)))
-
- ;; Add the non-store directories and files.
- (display "populating...\n")
- (populate-root-file-system system-directory target-directory))
+(define (initialize-partition partition)
+ "Format PARTITION, a <partition> object with a non-#f 'device' field, mount
+it, run its initializer, and unmount it."
+ (let ((target "/fs"))
+ (format-partition (partition-device partition)
+ (partition-file-system partition)
+ #:label (partition-label partition))
+ (mkdir-p target)
+ (mount (partition-device partition) target
+ (partition-file-system partition))
+
+ ((partition-initializer partition) target)
+
+ (umount target)
+ partition))
+
+(define* (root-partition-initializer #:key (closures '())
+ copy-closures?
+ (register-closures? #t)
+ system-directory)
+ "Return a procedure to initialize a root partition.
+
+If REGISTER-CLOSURES? is true, register all of CLOSURES is the partition's
+store. If COPY-CLOSURES? is true, copy all of CLOSURES to the partition.
+SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
+ (lambda (target)
+ (define target-store
+ (string-append target (%store-directory)))
+
+ (when copy-closures?
+ ;; Populate the store.
+ (populate-store (map (cut string-append "/xchg/" <>) closures)
+ target))
+
+ ;; Populate /dev.
+ (make-essential-device-nodes #:root target)
+
+ ;; Optionally, register the inputs in the image's store.
+ (when register-closures?
+ (unless copy-closures?
+ ;; XXX: 'guix-register' wants to palpate the things it registers, so
+ ;; bind-mount the store on the target.
+ (mkdir-p target-store)
+ (mount (%store-directory) target-store "" MS_BIND))
+
+ (display "registering closures...\n")
+ (for-each (lambda (closure)
+ (register-closure target
+ (string-append "/xchg/" closure)))
+ closures)
+ (unless copy-closures?
+ (umount target-store)))
+
+ ;; Add the non-store directories and files.
+ (display "populating...\n")
+ (populate-root-file-system system-directory target)
+
+ ;; 'guix-register' resets timestamps and everything, so no need to do it
+ ;; once more in that case.
+ (unless register-closures?
+ (reset-timestamps target))))
(define (register-grub.cfg-root target grub.cfg)
"On file system TARGET, register GRUB.CFG as a GC root."
@@ -186,56 +286,29 @@ volume name."
(define* (initialize-hard-disk device
#:key
- system-directory
grub.cfg
- disk-image-size
- (file-system-type "ext4")
- file-system-label
- (closures '())
- copy-closures?
- (bootable? #t)
- (register-closures? #t))
- "Initialize DEVICE, a disk of DISK-IMAGE-SIZE bytes, with a FILE-SYSTEM-TYPE
-partition with (optionally) FILE-SYSTEM-LABEL as its volume name, and with
-GRUB installed. When BOOTABLE? is true, set the bootable flag on that
-partition.
-
-If REGISTER-CLOSURES? is true, register all of CLOSURES is the partition's
-store. If COPY-CLOSURES? is true, copy all of CLOSURES to the partition.
-SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
- (define target-directory
- "/fs")
-
- (define partition
- (string-append device "1"))
-
- (initialize-partition-table device
- (- disk-image-size (* 5 (expt 2 20)))
- #:bootable? bootable?)
-
- (format-partition partition file-system-type
- #:label file-system-label)
-
- (display "mounting partition...\n")
- (mkdir target-directory)
- (mount partition target-directory file-system-type)
+ (partitions '()))
+ "Initialize DEVICE as a disk containing all the <partition> objects listed
+in PARTITIONS, and using GRUB.CFG as its bootloader configuration file.
- (initialize-root-partition target-directory
- #:system-directory system-directory
- #:copy-closures? copy-closures?
- #:register-closures? register-closures?
- #:closures closures)
+Each partition is initialized by calling its 'initializer' procedure,
+passing it a directory name where it is mounted."
+ (let* ((partitions (initialize-partition-table device partitions))
+ (root (find partition-bootable? partitions))
+ (target "/fs"))
+ (unless root
+ (error "no bootable partition specified" partitions))
- (install-grub grub.cfg device target-directory)
+ (for-each initialize-partition partitions)
- ;; Register GRUB.CFG as a GC root.
- (register-grub.cfg-root target-directory grub.cfg)
+ (display "mounting root partition...\n")
+ (mkdir-p target)
+ (mount (partition-device root) target (partition-file-system root))
+ (install-grub grub.cfg device target)
- ;; 'guix-register' resets timestamps and everything, so no need to do it
- ;; once more in that case.
- (unless register-closures?
- (reset-timestamps target-directory))
+ ;; Register GRUB.CFG as a GC root.
+ (register-grub.cfg-root target grub.cfg)
- (umount target-directory))
+ (umount target)))
;;; vm.scm ends here
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index eb27ebce3b..dfb6996067 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -101,6 +101,7 @@
(gnu build linux-modules)
(gnu build file-systems)
(guix elf)
+ (guix records)
(guix build utils)
(guix build syscalls)
(guix build store-copy)))
@@ -227,18 +228,24 @@ the image."
(set-path-environment-variable "PATH" '("bin" "sbin") inputs)
- (let ((graphs '#$(match inputs
- (((names . _) ...)
- names))))
+ (let* ((graphs '#$(match inputs
+ (((names . _) ...)
+ names)))
+ (initialize (root-partition-initializer
+ #:closures graphs
+ #:copy-closures? #$copy-inputs?
+ #:register-closures? #$register-closures?
+ #:system-directory #$os-derivation))
+ (partitions (list (partition
+ (size #$(- disk-image-size
+ (* 10 (expt 2 20))))
+ (label #$file-system-label)
+ (file-system #$file-system-type)
+ (bootable? #t)
+ (initializer initialize)))))
(initialize-hard-disk "/dev/vda"
- #:system-directory #$os-derivation
- #:grub.cfg #$grub-configuration
- #:closures graphs
- #:copy-closures? #$copy-inputs?
- #:register-closures? #$register-closures?
- #:disk-image-size #$disk-image-size
- #:file-system-type #$file-system-type
- #:file-system-label #$file-system-label)
+ #:partitions partitions
+ #:grub.cfg #$grub-configuration)
(reboot))))
#:system system
#:make-disk-image? #t