diff --git a/Makefile.am b/Makefile.am index ebe0f2559c..1d68e6516a 100644 --- a/Makefile.am +++ b/Makefile.am @@ -61,6 +61,7 @@ MODULES = \ guix/build/cmake-build-system.scm \ guix/build/gnu-build-system.scm \ guix/build/gnu-dist.scm \ + guix/build/linux-initrd.scm \ guix/build/perl-build-system.scm \ guix/build/python-build-system.scm \ guix/build/utils.scm \ diff --git a/gnu/packages/linux-initrd.scm b/gnu/packages/linux-initrd.scm index db54699ac1..2ed52e60f0 100644 --- a/gnu/packages/linux-initrd.scm +++ b/gnu/packages/linux-initrd.scm @@ -238,26 +238,17 @@ the Linux kernel.") (define-public qemu-initrd (expression->initrd '(begin - (use-modules (rnrs io ports) - (srfi srfi-1) + (use-modules (srfi srfi-1) (srfi srfi-26) (ice-9 match) - ((system foreign) #:select (string->pointer)) - ((system base compile) #:select (compile-file))) + ((system base compile) #:select (compile-file)) + (guix build linux-initrd)) - (display "Welcome, this is GNU/Guile!\n") + (display "Welcome, this is GNU's early boot Guile.\n") (display "Use '--repl' for an initrd REPL.\n\n") - (mkdir "/proc") - (mount "none" "/proc" "proc") - - (mkdir "/sys") - (mount "none" "/sys" "sysfs") - - (let* ((command (string-trim-both - (call-with-input-file "/proc/cmdline" - get-string-all))) - (args (string-split command char-set:blank)) + (mount-essential-file-systems) + (let* ((args (linux-command-line)) (option (lambda (opt) (let ((opt (string-append opt "="))) (and=> (find (cut string-prefix? opt <>) @@ -270,34 +261,13 @@ the Linux kernel.") (when (member "--repl" args) ((@ (system repl repl) start-repl))) - (let ((slurp (lambda (module) - (call-with-input-file - (string-append "/modules/" module) - get-bytevector-all)))) - (display "loading CIFS and companion modules...\n") - (for-each (compose load-linux-module slurp) - (list "md4.ko" "ecb.ko" "cifs.ko"))) + (display "loading CIFS and companion modules...\n") + (for-each (compose load-linux-module* + (cut string-append "/modules/" <>)) + (list "md4.ko" "ecb.ko" "cifs.ko")) - ;; See net/slirp.c for default QEMU networking values. - (display "configuring network...\n") - (let* ((sock (socket AF_INET SOCK_STREAM 0)) - (address (make-socket-address AF_INET - (inet-pton AF_INET - "10.0.2.10") - 0)) - (flags (network-interface-flags sock "eth0"))) - (set-network-interface-address sock "eth0" address) - (set-network-interface-flags sock "eth0" - (logior flags IFF_UP)) - (if (logand (network-interface-flags sock "eth0") IFF_UP) - (display "network interface is up\n") - (display "network interface is DOWN\n")) - - (mkdir "/etc") - (call-with-output-file "/etc/resolv.conf" - (lambda (p) - (display "nameserver 10.0.2.3\n" p))) - (sleep 1)) + (unless (configure-qemu-networking) + (display "network interface is DOWN\n")) ;; Prepare the real root file system under /root. (unless (file-exists? "/root") @@ -305,27 +275,19 @@ the Linux kernel.") (if root (mount root "/root" "ext3") (mount "none" "/root" "tmpfs")) - (mkdir "/root/proc") - (mount "none" "/root/proc" "proc") - (mkdir "/root/sys") - (mount "none" "/root/sys" "sysfs") + (mount-essential-file-systems #:root "/root") + (mkdir "/root/xchg") (mkdir "/root/nix") (mkdir "/root/nix/store") (mkdir "/root/dev") - (let ((makedev (lambda (major minor) - (+ (* major 256) minor)))) - (mknod "/root/dev/null" 'char-special #o666 (makedev 1 3)) - (mknod "/root/dev/zero" 'char-special #o666 (makedev 1 5))) + (mknod "/root/dev/null" 'char-special #o666 (device-number 1 3)) + (mknod "/root/dev/zero" 'char-special #o666 (device-number 1 5)) ;; Mount the host's store and exchange directory. - (display "mounting QEMU's SMB shares...\n") - (let ((server "10.0.2.4")) - (mount (string-append "//" server "/store") "/root/nix/store" "cifs" 0 - (string->pointer "guest,sec=none")) - (mount (string-append "//" server "/xchg") "/root/xchg" "cifs" 0 - (string->pointer "guest,sec=none"))) + (mount-qemu-smb-share "/store" "/root/nix/store") + (mount-qemu-smb-share "/xchg" "/root/xchg") (if to-load (begin @@ -346,6 +308,7 @@ the Linux kernel.") (display "entering a warm and cozy REPL\n") ((@ (system repl repl) start-repl)))))) #:name "qemu-initrd" + #:modules '((guix build linux-initrd)) #:linux linux-libre #:linux-modules '("cifs.ko" "md4.ko" "ecb.ko"))) diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm new file mode 100644 index 0000000000..274eef7ff3 --- /dev/null +++ b/guix/build/linux-initrd.scm @@ -0,0 +1,107 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 Ludovic Courtès +;;; +;;; 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 (guix build linux-initrd) + #:use-module (rnrs io ports) + #:use-module (system foreign) + #:export (mount-essential-file-systems + linux-command-line + configure-qemu-networking + mount-qemu-smb-share + load-linux-module* + device-number)) + +;;; Commentary: +;;; +;;; Utility procedures useful in a Linux initial RAM disk (initrd). Note that +;;; many of these use procedures not yet available in vanilla Guile (`mount', +;;; `load-linux-module', etc.); these are provided by a Guile patch used in +;;; the GNU distribution. +;;; +;;; Code: + +(define* (mount-essential-file-systems #:key (root "/")) + "Mount /proc and /sys under ROOT." + (define (scope dir) + (string-append root + (if (string-suffix? "/" root) + "" + "/") + dir)) + + (unless (file-exists? (scope "proc")) + (mkdir (scope "proc"))) + (mount "none" (scope "proc") "proc") + + (unless (file-exists? (scope "sys")) + (mkdir (scope "sys"))) + (mount "none" (scope "sys") "sysfs")) + +(define (linux-command-line) + "Return the Linux kernel command line as a list of strings." + (string-tokenize + (call-with-input-file "/proc/cmdline" + get-string-all))) + +(define %host-qemu-ipv4-address + (inet-pton AF_INET "10.0.2.10")) + +(define* (configure-qemu-networking #:optional (interface "eth0")) + "Setup the INTERFACE network interface and /etc/resolv.conf according to +QEMU's default networking settings (see net/slirp.c in QEMU for default +networking values.) Return #t if INTERFACE is up, #f otherwise." + (display "configuring QEMU networking...\n") + (let* ((sock (socket AF_INET SOCK_STREAM 0)) + (address (make-socket-address AF_INET %host-qemu-ipv4-address 0)) + (flags (network-interface-flags sock interface))) + (set-network-interface-address sock interface address) + (set-network-interface-flags sock interface (logior flags IFF_UP)) + + (unless (file-exists? "/etc") + (mkdir "/etc")) + (call-with-output-file "/etc/resolv.conf" + (lambda (p) + (display "nameserver 10.0.2.3\n" p))) + + (logand (network-interface-flags sock interface) IFF_UP))) + +(define (mount-qemu-smb-share share mount-point) + "Mount QEMU's CIFS/SMB SHARE at MOUNT-POINT. + +Vanilla QEMU's `-smb' option just exports a /qemu share, whereas our +`qemu-with-multiple-smb-shares' package exports the /xchg and /store shares + (the latter allows the store to be shared between the host and guest.)" + + (format #t "mounting QEMU's SMB share `~a'...\n" share) + (let ((server "10.0.2.4")) + (mount (string-append "//" server share) mount-point "cifs" 0 + (string->pointer "guest,sec=none")))) + +(define (load-linux-module* file) + "Load Linux module from FILE, the name of a `.ko' file." + (define (slurp module) + (call-with-input-file file get-bytevector-all)) + + (load-linux-module (slurp file))) + +(define (device-number major minor) + "Return the device number for the device with MAJOR and MINOR, for use as +the last argument of `mknod'." + (+ (* major 256) minor)) + +;;; linux-initrd.scm ends here