nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

253
gnu/build/vm.scm
View File

@ -21,13 +21,26 @@
#:use-module (guix build store-copy) #:use-module (guix build store-copy)
#:use-module (gnu build linux-boot) #:use-module (gnu build linux-boot)
#:use-module (gnu build install) #:use-module (gnu build install)
#:use-module (guix records)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 regex) #:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:export (qemu-command #:export (qemu-command
load-in-linux-vm load-in-linux-vm
format-partition 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-partition-table
initialize-hard-disk)) initialize-hard-disk))
@ -110,24 +123,84 @@ the #:references-graphs parameter of 'derivation'."
(mkdir output) (mkdir output)
(copy-recursively "xchg" 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 #:key
bootable?
(label-type "msdos") (label-type "msdos")
(offset (expt 2 20))) (offset (expt 2 20)))
"Create on DEVICE a partition table of type LABEL-TYPE, with a single "Create on DEVICE a partition table of type LABEL-TYPE, containing the given
partition of PARTITION-SIZE bytes starting at OFFSET bytes. When BOOTABLE? is PARTITIONS (a list of <partition> objects), starting at OFFSET bytes. On
true, set the bootable flag on the partition. Return #t on success." success, return PARTITIONS with their 'device' field changed to reflect their
(format #t "creating partition table with a ~a B partition...\n" actual /dev name based on DEVICE."
partition-size) (define (partition-options part offset index)
(unless (zero? (apply system* "parted" device "mklabel" label-type (cons* "mkpart" "primary" "ext2"
"mkpart" "primary" "ext2" (format #f "~aB" offset)
(format #f "~aB" offset) (format #f "~aB" (+ offset (partition-size part)))
(format #f "~aB" partition-size) (if (partition-bootable? part)
(if bootable? `("set" ,(number->string index) "boot" "on")
'("set" "1" "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! (define MS_BIND 4096) ; <sys/mounts.h> again!
@ -143,40 +216,67 @@ volume name."
'()))) '())))
(error "failed to create partition"))) (error "failed to create partition")))
(define* (initialize-root-partition target-directory (define (initialize-partition partition)
#:key copy-closures? register-closures? "Format PARTITION, a <partition> object with a non-#f 'device' field, mount
closures system-directory) it, run its initializer, and unmount it."
"Initialize the root partition mounted at TARGET-DIRECTORY." (let ((target "/fs"))
(define target-store (format-partition (partition-device partition)
(string-append target-directory (%store-directory))) (partition-file-system partition)
#:label (partition-label partition))
(mkdir-p target)
(mount (partition-device partition) target
(partition-file-system partition))
(when copy-closures? ((partition-initializer partition) target)
;; Populate the store.
(populate-store (map (cut string-append "/xchg/" <>) closures)
target-directory))
;; Populate /dev. (umount target)
(make-essential-device-nodes #:root target-directory) partition))
;; Optionally, register the inputs in the image's store. (define* (root-partition-initializer #:key (closures '())
(when register-closures? copy-closures?
(unless copy-closures? (register-closures? #t)
;; XXX: 'guix-register' wants to palpate the things it registers, so system-directory)
;; bind-mount the store on the target. "Return a procedure to initialize a root partition.
(mkdir-p target-store)
(mount (%store-directory) target-store "" MS_BIND))
(display "registering closures...\n") If REGISTER-CLOSURES? is true, register all of CLOSURES is the partition's
(for-each (lambda (closure) store. If COPY-CLOSURES? is true, copy all of CLOSURES to the partition.
(register-closure target-directory SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
(string-append "/xchg/" closure))) (lambda (target)
closures) (define target-store
(unless copy-closures? (string-append target (%store-directory)))
(umount target-store)))
;; Add the non-store directories and files. (when copy-closures?
(display "populating...\n") ;; Populate the store.
(populate-root-file-system system-directory target-directory)) (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) (define (register-grub.cfg-root target grub.cfg)
"On file system TARGET, register GRUB.CFG as a GC root." "On file system TARGET, register GRUB.CFG as a GC root."
@ -186,56 +286,29 @@ volume name."
(define* (initialize-hard-disk device (define* (initialize-hard-disk device
#:key #:key
system-directory
grub.cfg grub.cfg
disk-image-size (partitions '()))
(file-system-type "ext4") "Initialize DEVICE as a disk containing all the <partition> objects listed
file-system-label in PARTITIONS, and using GRUB.CFG as its bootloader configuration file.
(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 Each partition is initialized by calling its 'initializer' procedure,
store. If COPY-CLOSURES? is true, copy all of CLOSURES to the partition. passing it a directory name where it is mounted."
SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation." (let* ((partitions (initialize-partition-table device partitions))
(define target-directory (root (find partition-bootable? partitions))
"/fs") (target "/fs"))
(unless root
(error "no bootable partition specified" partitions))
(define partition (for-each initialize-partition partitions)
(string-append device "1"))
(initialize-partition-table device (display "mounting root partition...\n")
(- disk-image-size (* 5 (expt 2 20))) (mkdir-p target)
#:bootable? bootable?) (mount (partition-device root) target (partition-file-system root))
(install-grub grub.cfg device target)
(format-partition partition file-system-type ;; Register GRUB.CFG as a GC root.
#:label file-system-label) (register-grub.cfg-root target grub.cfg)
(display "mounting partition...\n") (umount target)))
(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)
;; Register GRUB.CFG as a GC root.
(register-grub.cfg-root target-directory 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))
;;; vm.scm ends here ;;; vm.scm ends here

29
gnu/system/vm.scm
View File

@ -101,6 +101,7 @@
(gnu build linux-modules) (gnu build linux-modules)
(gnu build file-systems) (gnu build file-systems)
(guix elf) (guix elf)
(guix records)
(guix build utils) (guix build utils)
(guix build syscalls) (guix build syscalls)
(guix build store-copy))) (guix build store-copy)))
@ -227,18 +228,24 @@ the image."
(set-path-environment-variable "PATH" '("bin" "sbin") inputs) (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
(let ((graphs '#$(match inputs (let* ((graphs '#$(match inputs
(((names . _) ...) (((names . _) ...)
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" (initialize-hard-disk "/dev/vda"
#:system-directory #$os-derivation #:partitions partitions
#:grub.cfg #$grub-configuration #: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)
(reboot)))) (reboot))))
#:system system #:system system
#:make-disk-image? #t #:make-disk-image? #t