diff options
Diffstat (limited to 'gnu/build')
| -rw-r--r-- | gnu/build/bootloader.scm | 37 | ||||
| -rw-r--r-- | gnu/build/linux-boot.scm | 107 | ||||
| -rw-r--r-- | gnu/build/vm.scm | 44 |
3 files changed, 178 insertions, 10 deletions
diff --git a/gnu/build/bootloader.scm b/gnu/build/bootloader.scm new file mode 100644 index 0000000000..d00674dd40 --- /dev/null +++ b/gnu/build/bootloader.scm @@ -0,0 +1,37 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (gnu build bootloader) + #:use-module (ice-9 binary-ports) + #:export (write-file-on-device)) + + +;;; +;;; Writing utils. +;;; + +(define (write-file-on-device file size device offset) + "Write SIZE bytes from FILE to DEVICE starting at OFFSET." + (call-with-input-file file + (lambda (input) + (let ((bv (get-bytevector-n input size))) + (call-with-output-file device + (lambda (output) + (seek output offset SEEK_SET) + (put-bytevector output bv)) + #:binary #t))))) diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm index 2547f1e0af..4dd740174e 100644 --- a/gnu/build/linux-boot.scm +++ b/gnu/build/linux-boot.scm @@ -22,8 +22,11 @@ #:use-module (system repl error-handling) #:autoload (system repl repl) (start-repl) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) #:use-module (ice-9 ftw) #:use-module (guix build utils) #:use-module ((guix build syscalls) @@ -35,6 +38,7 @@ linux-command-line find-long-option make-essential-device-nodes + make-static-device-nodes configure-qemu-networking bind-mount @@ -105,6 +109,109 @@ with the given MAJOR number, starting with MINOR." 'block-special #o644 (device-number major (+ minor i))) (loop (+ i 1))))) +;; Representation of a /dev node. +(define-record-type <device-node> + (device-node name type major minor module) + device-node? + (name device-node-name) + (type device-node-type) + (major device-node-major) + (minor device-node-minor) + (module device-node-module)) + +(define (read-static-device-nodes port) + "Read from PORT a list of <device-node> written in the format used by +/lib/modules/*/*.devname files." + (let loop ((line (read-line port))) + (if (eof-object? line) + '() + (match (string-split line #\space) + (((? (cut string-prefix? "#" <>)) _ ...) + (loop (read-line port))) + ((module-name device-name device-spec) + (let* ((device-parts + (string-match "([bc])([0-9][0-9]*):([0-9][0-9]*)" + device-spec)) + (type-string (match:substring device-parts 1)) + (type (match type-string + ("c" 'char-special) + ("b" 'block-special))) + (major-string (match:substring device-parts 2)) + (major (string->number major-string 10)) + (minor-string (match:substring device-parts 3)) + (minor (string->number minor-string 10))) + (cons (device-node device-name type major minor module-name) + (loop (read-line port))))) + (_ + (begin + (format (current-error-port) + "read-static-device-nodes: ignored devname line '~a'~%" line) + (loop (read-line port)))))))) + +(define* (mkdir-p* dir #:optional (mode #o755)) + "This is a variant of 'mkdir-p' that works around +<http://bugs.gnu.org/24659> by passing MODE explicitly in each 'mkdir' call." + (define absolute? + (string-prefix? "/" dir)) + + (define not-slash + (char-set-complement (char-set #\/))) + + (let loop ((components (string-tokenize dir not-slash)) + (root (if absolute? + "" + "."))) + (match components + ((head tail ...) + (let ((path (string-append root "/" head))) + (catch 'system-error + (lambda () + (mkdir path mode) + (loop tail path)) + (lambda args + (if (= EEXIST (system-error-errno args)) + (loop tail path) + (apply throw args)))))) + (() #t)))) + +(define (report-system-error name . args) + "Report a system error for the file NAME." + (let ((errno (system-error-errno args))) + (format (current-error-port) "could not create '~a': ~a~%" name + (strerror errno)))) + +;; Catch a system-error, log it and don't die from it. +(define-syntax-rule (catch-system-error name exp) + (catch 'system-error + (lambda () + exp) + (lambda args + (apply report-system-error name args)))) + +;; Create a device node like the <device-node> passed here on the filesystem. +(define create-device-node + (match-lambda + (($ <device-node> xname type major minor module) + (let ((name (string-append "/dev/" xname))) + (mkdir-p* (dirname name)) + (catch-system-error name + (mknod name type #o600 (device-number major minor))))))) + +(define* (make-static-device-nodes linux-release-module-directory) + "Create static device nodes required by the given Linux release. +This is required in order to solve a chicken-or-egg problem: +The Linux kernel has a feature to autoload modules when a device is first +accessed. +And udev has a feature to set the permissions of static nodes correctly +when it is starting up and also to automatically create nodes when hardware +is hotplugged. That leaves universal device files which are not linked to +one specific hardware device. These we have to create." + (let ((devname-name (string-append linux-release-module-directory "/" + "modules.devname"))) + (for-each create-device-node + (call-with-input-file devname-name + read-static-device-nodes)))) + (define* (make-essential-device-nodes #:key (root "/")) "Make essential device nodes under ROOT/dev." ;; The hand-made devtmpfs/udev! diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index 20ee12709b..404f324045 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org> -;;; Copyright © 2016 Leo Famulari <leo@famulari.name> +;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com> ;;; @@ -77,6 +77,7 @@ linux initrd make-disk-image? single-file-output? + target-arm32? (disk-image-size (* 100 (expt 2 20))) (disk-image-format "qcow2") (references-graphs '())) @@ -91,6 +92,31 @@ access it via /dev/hda. REFERENCES-GRAPHS can specify a list of reference-graph files as produced by the #:references-graphs parameter of 'derivation'." + + (define arch-specific-flags + `(;; On ARM, a machine has to be specified. Use "virt" machine to avoid + ;; hardware limits imposed by other machines. + ,@(if target-arm32? '("-M" "virt") '()) + + ;; Only enable kvm if we see /dev/kvm exists. This allows users without + ;; hardware virtualization to still use these commands. KVM support is + ;; still buggy on some ARM32 boards. Do not use it even if available. + ,@(if (and (file-exists? "/dev/kvm") + (not target-arm32?)) + '("-enable-kvm") + '()) + "-append" + ;; The serial port name differs between emulated architectures/machines. + ,@(if target-arm32? + `(,(string-append "console=ttyAMA0 --load=" builder)) + `(,(string-append "console=ttyS0 --load=" builder))) + ;; NIC is not supported on ARM "virt" machine, so use a user mode + ;; network stack instead. + ,@(if target-arm32? + '("-device" "virtio-net-pci,netdev=mynet" + "-netdev" "user,id=mynet") + '("-net" "nic,model=virtio")))) + (when make-disk-image? (format #t "creating ~a image of ~,2f MiB...~%" disk-image-format (/ disk-image-size (expt 2 20))) @@ -113,7 +139,8 @@ the #:references-graphs parameter of 'derivation'." (unless (zero? (apply system* qemu "-nographic" "-no-reboot" "-m" (number->string memory-size) - "-net" "nic,model=virtio" + "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng" + "-device" "virtio-rng-pci,rng=guixsd-vm-rng" "-virtfs" (string-append "local,id=store_dev,path=" (%store-directory) @@ -127,15 +154,12 @@ the #:references-graphs parameter of 'derivation'." builder) (append (if make-disk-image? - `("-drive" ,(string-append "file=" output - ",if=virtio")) + `("-device" "virtio-blk,drive=myhd" + "-drive" ,(string-append "if=none,file=" output + ",format=" disk-image-format + ",id=myhd")) '()) - ;; 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") - '())))) + arch-specific-flags))) (error "qemu failed" qemu)) ;; When MAKE-DISK-IMAGE? is true, the image is in OUTPUT already. |