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.
master
Ludovic Courtès 2015-07-25 23:57:52 +02:00
parent 5b9da1f955
commit 72b891e50e
2 changed files with 181 additions and 101 deletions

View File

@ -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"
"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" partition-size)
(if bootable?
'("set" "1" "boot" "on")
(format #f "~aB" (+ offset (partition-size part)))
(if (partition-bootable? part)
`("set" ,(number->string index) "boot" "on")
'())))
(error "failed to create partition table")))
(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,20 +216,42 @@ 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 (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-directory (%store-directory)))
(string-append target (%store-directory)))
(when copy-closures?
;; Populate the store.
(populate-store (map (cut string-append "/xchg/" <>) closures)
target-directory))
target))
;; Populate /dev.
(make-essential-device-nodes #:root target-directory)
(make-essential-device-nodes #:root target)
;; Optionally, register the inputs in the image's store.
(when register-closures?
@ -168,7 +263,7 @@ volume name."
(display "registering closures...\n")
(for-each (lambda (closure)
(register-closure target-directory
(register-closure target
(string-append "/xchg/" closure)))
closures)
(unless copy-closures?
@ -176,7 +271,12 @@ volume name."
;; Add the non-store directories and files.
(display "populating...\n")
(populate-root-file-system system-directory target-directory))
(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.
(partitions '()))
"Initialize DEVICE as a disk containing all the <partition> objects listed
in PARTITIONS, and using GRUB.CFG as its bootloader configuration file.
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")
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))
(define partition
(string-append device "1"))
(for-each initialize-partition partitions)
(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)
(initialize-root-partition target-directory
#:system-directory system-directory
#:copy-closures? copy-closures?
#:register-closures? register-closures?
#:closures closures)
(install-grub grub.cfg device target-directory)
(display "mounting root partition...\n")
(mkdir-p target)
(mount (partition-device root) target (partition-file-system root))
(install-grub grub.cfg device target)
;; Register GRUB.CFG as a GC root.
(register-grub.cfg-root target-directory grub.cfg)
(register-grub.cfg-root target grub.cfg)
;; 'guix-register' resets timestamps and everything, so no need to do it
;; once more in that case.
(unless register-closures?
(reset-timestamps target-directory))
(umount target-directory))
(umount target)))
;;; vm.scm ends here

View File

@ -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
(let* ((graphs '#$(match inputs
(((names . _) ...)
names))))
(initialize-hard-disk "/dev/vda"
#:system-directory #$os-derivation
#:grub.cfg #$grub-configuration
names)))
(initialize (root-partition-initializer
#: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)
#: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"
#:partitions partitions
#:grub.cfg #$grub-configuration)
(reboot))))
#:system system
#:make-disk-image? #t