Merge branch 'master' into core-updates

2 files changed, 173 insertions, 4 deletions

diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm
new file mode 100644
index 0000000000..b5404da7f0
--- /dev/null
+++ b/guix/build/linux-initrd.scm
@@ -0,0 +1,148 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013 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 (guix build linux-initrd)
+  #:use-module (rnrs io ports)
+  #:use-module (system foreign)
+  #:export (mount-essential-file-systems
+            linux-command-line
+            make-essential-device-nodes
+            configure-qemu-networking
+            mount-qemu-smb-share
+            bind-mount
+            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* (make-essential-device-nodes #:key (root "/"))
+  "Make essential device nodes under ROOT/dev."
+  ;; The hand-made udev!
+
+  (define (scope dir)
+    (string-append root
+                   (if (string-suffix? "/" root)
+                       ""
+                       "/")
+                   dir))
+
+  (unless (file-exists? (scope "dev"))
+    (mkdir (scope "dev")))
+
+  ;; Make the device nodes for QEMU's hard disk and partitions.
+  (mknod (scope "dev/vda") 'block-special #o644 (device-number 8 0))
+  (mknod (scope "dev/vda1") 'block-special #o644 (device-number 8 1))
+  (mknod (scope "dev/vda2") 'block-special #o644 (device-number 8 2))
+
+  ;; TTYs.
+  (mknod (scope "dev/tty") 'char-special #o600
+         (device-number 5 0))
+  (let loop ((n 0))
+    (and (< n 50)
+         (let ((name (format #f "dev/tty~a" n)))
+           (mknod (scope name) 'char-special #o600
+                  (device-number 4 n))
+           (loop (+ 1 n)))))
+
+  ;; Other useful nodes.
+  (mknod (scope "dev/null") 'char-special #o666 (device-number 1 3))
+  (mknod (scope "dev/zero") 'char-special #o666 (device-number 1 5)))
+
+(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 (bind-mount source target)
+  "Bind-mount SOURCE at TARGET."
+  (define MS_BIND 4096)                           ; from libc's <sys/mount.h>
+
+  (mount source target "" MS_BIND))
+
+(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
diff --git a/guix/build/union.scm b/guix/build/union.scm
index 275746d83e..077b7fe530 100644
--- a/guix/build/union.scm
+++ b/guix/build/union.scm
@@ -105,7 +105,22 @@ single leaf."
 the DIRECTORIES."
   (define (file-tree dir)
     ;; Return the contents of DIR as a tree.
-    (match (file-system-fold (const #t)
+
+    (define (others-have-it? subdir)
+      ;; Return #t if other elements of DIRECTORIES have SUBDIR.
+      (let ((subdir (substring subdir (string-length dir))))
+        (any (lambda (other)
+               (and (not (string=? other dir))
+                    (file-exists? (string-append other "/" subdir))))
+             directories)))
+
+    (match (file-system-fold (lambda (subdir stat result) ; enter?
+                               ;; No need to traverse DIR since there's
+                               ;; nothing to union it with.  Thus, we avoid
+                               ;; creating a gazillon symlinks (think
+                               ;; share/emacs/24.3, share/texmf, etc.)
+                               (or (string=? subdir dir)
+                                   (others-have-it? subdir)))
                              (lambda (file stat result) ; leaf
                                (match result
                                  (((siblings ...) rest ...)
@@ -117,7 +132,12 @@ the DIRECTORIES."
                                  (((leaves ...) (siblings ...) rest ...)
                                   `(((,(basename dir) ,@leaves) ,@siblings)
                                     ,@rest))))
-                             (const #f)                 ; skip
+                             (lambda (dir stat result)  ; skip
+                               ;; DIR is not available elsewhere, so treat it
+                               ;; as a leaf.
+                               (match result
+                                 (((siblings ...) rest ...)
+                                  `((,dir ,@siblings) ,@rest))))
                              (lambda (file stat errno result)
                                (format (current-error-port) "union-build: ~a: ~a~%"
                                        file (strerror errno)))
@@ -158,8 +178,9 @@ the DIRECTORIES."
   (mkdir output)
   (let loop ((tree (delete-duplicate-leaves
                     (cons "."
-                          (tree-union (append-map (compose tree-leaves file-tree)
-                                                  directories)))
+                          (tree-union
+                           (append-map (compose tree-leaves file-tree)
+                                       (delete-duplicates directories))))
                     leaf=?
                     resolve-collision))
              (dir  '()))