;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2016 Christopher Allan Webber ;;; Copyright © 2016 Leo Famulari ;;; ;;; This file is part of GNU Guix. ;;; ;;; GNU Guix is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or (at ;;; your option) any later version. ;;; ;;; GNU Guix is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . (define-module (gnu build vm) #:use-module (guix build utils) #:use-module (gu
aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/services/pm.scm')
0 files changed, 0 insertions, 0 deletions
;; Only enable kvm if we see /dev/kvm exists. ;; This allows users without hardware virtualization to still ;; use these commands. (if (file-exists? "/dev/kvm") '("-enable-kvm") '())))) (error "qemu failed" qemu)) ;; When MAKE-DISK-IMAGE? is true, the image is in OUTPUT already. (unless make-disk-image? (mkdir output) (copy-recursively "xchg" output))) ;;; ;;; Partitions. ;;; (define-record-type* 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 (label-type "msdos") (offset (expt 2 20))) "Create on DEVICE a partition table of type LABEL-TYPE, containing the given PARTITIONS (a list of 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) ; again! (define* (format-partition partition type #:key label) "Create a file system TYPE on PARTITION. If LABEL is true, use that as the volume name." (format #t "creating ~a partition...\n" type) (unless (zero? (apply system* (string-append "mkfs." type) "-F" partition (if label `("-L" ,label) '()))) (error "failed to create partition"))) (define (initialize-partition partition) "Format PARTITION, a 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." (let ((directory (string-append target "/var/guix/gcroots"))) (mkdir-p directory) (symlink grub.cfg (string-append directory "/grub.cfg")))) (define* (initialize-hard-disk device #:key grub.cfg (partitions '())) "Initialize DEVICE as a disk containing all the objects listed in PARTITIONS, and using GRUB.CFG as its bootloader configuration file. 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)) (for-each initialize-partition partitions) (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 grub.cfg) (umount target))) ;;; vm.scm ends here