diff options
Diffstat (limited to 'gnu/build')
| -rw-r--r-- | gnu/build/activation.scm | 30 | ||||
| -rw-r--r-- | gnu/build/install.scm | 10 | ||||
| -rw-r--r-- | gnu/build/linux-boot.scm | 43 | ||||
| -rw-r--r-- | gnu/build/linux-modules.scm | 166 | ||||
| -rw-r--r-- | gnu/build/vm.scm | 9 |
5 files changed, 227 insertions, 31 deletions
diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm index 3eebb71dfc..dfadde326c 100644 --- a/gnu/build/activation.scm +++ b/gnu/build/activation.scm @@ -50,6 +50,25 @@ ,name))) (zero? (apply system* "groupadd" args)))) +(define %skeleton-directory + ;; Directory containing skeleton files for new accounts. + ;; Note: keep the trailing '/' so that 'scandir' enters it. + "/etc/skel/") + +(define (dot-or-dot-dot? file) + (member file '("." ".."))) + +(define* (copy-account-skeletons home + #:optional (directory %skeleton-directory)) + "Copy the account skeletons from DIRECTORY to HOME." + (let ((files (scandir directory (negate dot-or-dot-dot?) + string<?))) + (mkdir-p home) + (for-each (lambda (file) + (copy-file (string-append directory "/" file) + (string-append home "/" file))) + files))) + (define* (add-user name group #:key uid comment home shell password system? (supplementary-groups '()) @@ -70,6 +89,7 @@ properties. Return #t on success." (cut format <> "~a:x:~a:~a:~a:~a:~a~%" name "0" "0" comment home shell)) (chmod "/etc/shadow" #o600) + (copy-account-skeletons (or home "/root")) #t) ;; Use 'useradd' from the Shadow package. @@ -198,18 +218,12 @@ numeric gid or #f." ;; XXX: Dirty hack to meet sudo's expectations. (when (string=? (basename target) "sudoers") (chmod target #o440)))) - (scandir etc - (lambda (file) - (not (member file '("." "..")))) + (scandir etc (negate dot-or-dot-dot?) ;; The default is 'string-locale<?', but we don't have ;; it when run from the initrd's statically-linked ;; Guile. - string<?)) - - ;; Prevent ETC from being GC'd. - (rm-f "/var/guix/gcroots/etc-directory") - (symlink etc "/var/guix/gcroots/etc-directory")) + string<?))) (define %setuid-directory ;; Place where setuid programs are stored. diff --git a/gnu/build/install.scm b/gnu/build/install.scm index a472259a4a..aa901f6971 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -36,13 +36,17 @@ (define* (install-grub grub.cfg device mount-point) "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on -MOUNT-POINT." +MOUNT-POINT. + +Note that the caller must make sure that GRUB.CFG is registered as a GC root +so that the fonts, background images, etc. referred to by GRUB.CFG are not +GC'd." (let* ((target (string-append mount-point "/boot/grub/grub.cfg")) (pivot (string-append target ".new"))) (mkdir-p (dirname target)) - ;; Copy GRUB.CFG instead of just symlinking it since it's not a GC root. - ;; Do that atomically. + ;; Copy GRUB.CFG instead of just symlinking it, because symlinks won't + ;; work when /boot is on a separate partition. Do that atomically. (copy-file grub.cfg pivot) (rename-file pivot target) diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm index ea1971ff9c..b2ed1a8b54 100644 --- a/gnu/build/linux-boot.scm +++ b/gnu/build/linux-boot.scm @@ -26,6 +26,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 ftw) #:use-module (guix build utils) + #:use-module (gnu build linux-modules) #:use-module (gnu build file-systems) #:export (mount-essential-file-systems linux-command-line @@ -34,7 +35,6 @@ configure-qemu-networking bind-mount - load-linux-module* device-number boot-system)) @@ -218,14 +218,6 @@ networking values.) Return #t if INTERFACE is up, #f otherwise." (logand (network-interface-flags sock interface) IFF_UP))) -(define (load-linux-module* file) - "Load Linux module from FILE, the name of a `.ko' file." - (define (slurp module) - ;; TODO: Use 'mmap' to reduce memory usage. - (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'." @@ -332,16 +324,17 @@ bailing out.~%root contents: ~s~%" (scandir "/")) (define* (boot-system #:key (linux-modules '()) + linux-module-directory qemu-guest-networking? volatile-root? pre-mount (mounts '())) "This procedure is meant to be called from an initrd. Boot a system by -first loading LINUX-MODULES (a list of absolute file names of '.ko' files), -then setting up QEMU guest networking if QEMU-GUEST-NETWORKING? is true, -calling PRE-MOUNT, mounting the file systems specified in MOUNTS, and finally -booting into the new root if any. The initrd supports kernel command-line -options '--load', '--root', and '--repl'. +first loading LINUX-MODULES (a list of module names) from +LINUX-MODULE-DIRECTORY, then setting up QEMU guest networking if +QEMU-GUEST-NETWORKING? is true, calling PRE-MOUNT, mounting the file systems +specified in MOUNTS, and finally booting into the new root if any. The initrd +supports kernel command-line options '--load', '--root', and '--repl'. Mount the root file system, specified by the '--root' command-line argument, if any. @@ -362,6 +355,10 @@ to it are lost." mounts) "ext4")) + (define (lookup-module name) + (string-append linux-module-directory "/" + (ensure-dot-ko name))) + (display "Welcome, this is GNU's early boot Guile.\n") (display "Use '--repl' for an initrd REPL.\n\n") @@ -376,7 +373,10 @@ to it are lost." (start-repl)) (display "loading kernel modules...\n") - (for-each load-linux-module* linux-modules) + (current-module-debugging-port (current-output-port)) + (for-each (cut load-linux-module* <> + #:lookup-module lookup-module) + (map lookup-module linux-modules)) (when qemu-guest-networking? (unless (configure-qemu-networking) @@ -388,6 +388,14 @@ to it are lost." ;; Prepare the real root file system under /root. (unless (file-exists? "/root") (mkdir "/root")) + + (when (procedure? pre-mount) + ;; Do whatever actions are needed before mounting the root file + ;; system--e.g., installing device mappings. Error out when the + ;; return value is false. + (unless (pre-mount) + (error "pre-mount actions failed"))) + (if root (mount-root-file-system (canonicalize-device-spec root) root-fs-type @@ -398,11 +406,6 @@ to it are lost." (mkdir "/root/dev") (make-essential-device-nodes #:root "/root")) - (when (procedure? pre-mount) - ;; Do whatever actions are needed before mounting--e.g., installing - ;; device mappings. - (pre-mount)) - ;; Mount the specified file systems. (for-each mount-file-system (remove root-mount-point? mounts)) diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm new file mode 100644 index 0000000000..a3bc7d6e33 --- /dev/null +++ b/gnu/build/linux-modules.scm @@ -0,0 +1,166 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org> +;;; +;;; 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 linux-modules) + #:use-module (guix elf) + #:use-module (rnrs io ports) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (ice-9 vlist) + #:use-module (ice-9 match) + #:export (dot-ko + ensure-dot-ko + module-dependencies + recursive-module-dependencies + modules-loaded + module-loaded? + load-linux-module* + + current-module-debugging-port)) + +;;; Commentary: +;;; +;;; Tools to deal with Linux kernel modules. +;;; +;;; Code: + +(define current-module-debugging-port + (make-parameter (%make-void-port "w"))) + +(define (section-contents elf section) + "Return the contents of SECTION in ELF as a bytevector." + (let* ((modinfo (elf-section-by-name elf ".modinfo")) + (contents (make-bytevector (elf-section-size modinfo)))) + (bytevector-copy! (elf-bytes elf) (elf-section-offset modinfo) + contents 0 + (elf-section-size modinfo)) + contents)) + +(define %not-nul + (char-set-complement (char-set #\nul))) + +(define (nul-separated-string->list str) + "Split STR at occurrences of the NUL character and return the resulting +string list." + (string-tokenize str %not-nul)) + +(define (key=value->pair str) + "Assuming STR has the form \"KEY=VALUE\", return a pair like (KEY +. \"VALUE\")." + (let ((= (string-index str #\=))) + (cons (string->symbol (string-take str =)) + (string-drop str (+ 1 =))))) + +(define (modinfo-section-contents file) + "Return the contents of the '.modinfo' section of FILE as a list of +key/value pairs.." + (let* ((bv (call-with-input-file file get-bytevector-all)) + (elf (parse-elf bv)) + (modinfo (section-contents elf ".modinfo"))) + (map key=value->pair + (nul-separated-string->list (utf8->string modinfo))))) + +(define %not-comma + (char-set-complement (char-set #\,))) + +(define (module-dependencies file) + "Return the list of modules that FILE depends on. The returned list +contains module names, not actual file names." + (let ((info (modinfo-section-contents file))) + (match (assq 'depends info) + (('depends . what) + (string-tokenize what %not-comma))))) + +(define dot-ko + (cut string-append <> ".ko")) + +(define (ensure-dot-ko name) + "Return NAME with a '.ko' prefix appended, unless it already has it." + (if (string-suffix? ".ko" name) + name + (dot-ko name))) + +(define* (recursive-module-dependencies files + #:key (lookup-module dot-ko)) + "Return the topologically-sorted list of file names of the modules depended +on by FILES, recursively. File names of modules are determined by applying +LOOKUP-MODULE to the module name." + (let loop ((files files) + (result '()) + (visited vlist-null)) + (match files + (() + (delete-duplicates (reverse result))) + ((head . tail) + (let* ((visited? (vhash-assoc head visited)) + (deps (if visited? + '() + (map lookup-module (module-dependencies head)))) + (visited (if visited? + visited + (vhash-cons head #t visited)))) + (loop (append deps tail) + (append result deps) visited)))))) + +(define %not-newline + (char-set-complement (char-set #\newline))) + +(define (modules-loaded) + "Return the list of names of currently loaded Linux modules." + (let* ((contents (call-with-input-file "/proc/modules" + get-string-all)) + (lines (string-tokenize contents %not-newline))) + (match (map string-tokenize lines) + (((modules . _) ...) + modules)))) + +(define (module-loaded? module) + "Return #t if MODULE is already loaded. MODULE must be a Linux module name, +not a file name." + (member module (modules-loaded))) + +(define* (load-linux-module* file + #:key + (recursive? #t) + (lookup-module dot-ko)) + "Load Linux module from FILE, the name of a `.ko' file. When RECURSIVE? is +true, load its dependencies first (à la 'modprobe'.) The actual files +containing modules depended on are obtained by calling LOOKUP-MODULE with the +module name." + (define (slurp module) + ;; TODO: Use 'mmap' to reduce memory usage. + (call-with-input-file file get-bytevector-all)) + + (when recursive? + (for-each (cut load-linux-module* <> #:lookup-module lookup-module) + (map lookup-module (module-dependencies file)))) + + (format (current-module-debugging-port) + "loading Linux module from '~a'...~%" file) + + (catch 'system-error + (lambda () + (load-linux-module (slurp file))) + (lambda args + ;; If this module was already loaded and we're in modprobe style, ignore + ;; the error. + (unless (and recursive? (= EEXIST (system-error-errno args))) + (apply throw args))))) + +;;; linux-modules.scm ends here diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index 03db1cd5f9..2c53cf5dd9 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -178,6 +178,12 @@ volume name." (display "populating...\n") (populate-root-file-system system-directory target-directory)) +(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 system-directory @@ -222,6 +228,9 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation." (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? |