Merge branch 'master' into 'core-updates'.

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?