Merge branch 'master' into core-updates

Conflicts:
	gnu-system.am

4 files changed, 271 insertions, 25 deletions

diff --git a/guix/build/download.scm b/guix/build/download.scm
index ac2086d96e..f9715e10f7 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -201,6 +201,12 @@ which is not available during bootstrap."
         (string>? (micro-version) "7")
         (string>? (version) "2.0.7")))
 
+  (define headers
+    ;; Some web sites, such as http://dist.schmorp.de, would block you if
+    ;; there's no 'User-Agent' header, presumably on the assumption that
+    ;; you're a spammer.  So work around that.
+    '((User-Agent . "GNU Guile")))
+
   (let*-values (((connection)
                  (open-connection-for-uri uri))
                 ((resp bv-or-port)
@@ -210,11 +216,14 @@ which is not available during bootstrap."
                  ;; version.  So keep this compatibility hack for now.
                  (if post-2.0.7?
                      (http-get uri #:port connection #:decode-body? #f
-                               #:streaming? #t)
+                               #:streaming? #t
+                               #:headers headers)
                      (if (module-defined? (resolve-interface '(web client))
                                           'http-get*)
-                         (http-get* uri #:port connection #:decode-body? #f)
-                         (http-get uri #:port connection #:decode-body? #f))))
+                         (http-get* uri #:port connection #:decode-body? #f
+                                    #:headers headers)
+                         (http-get uri #:port connection #:decode-body? #f
+                                   #:extra-headers headers))))
                 ((code)
                  (response-code resp))
                 ((size)
diff --git a/guix/build/git.scm b/guix/build/git.scm
new file mode 100644
index 0000000000..4245594c38
--- /dev/null
+++ b/guix/build/git.scm
@@ -0,0 +1,45 @@
+;;; 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 (guix build git)
+  #:use-module (guix build utils)
+  #:export (git-fetch))
+
+;;; Commentary:
+;;;
+;;; This is the build-side support code of (guix git-download).  It allows a
+;;; Git repository to be cloned and checked out at a specific commit.
+;;;
+;;; Code:
+
+(define* (git-fetch url commit directory
+                    #:key (git-command "git"))
+  "Fetch COMMIT from URL into DIRECTORY.  COMMIT must be a valid Git commit
+identifier.  Return #t on success, #f otherwise."
+  (and (zero? (system* git-command "clone" url directory))
+       (with-directory-excursion directory
+         (system* git-command "tag" "-l")
+         (and (zero? (system* git-command "checkout" commit))
+              (begin
+                ;; The contents of '.git' vary as a function of the current
+                ;; status of the Git repo.  Since we want a fixed output, this
+                ;; directory needs to be taken out.
+                (delete-file-recursively ".git")
+                #t)))))
+
+;;; git.scm ends here
diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm
index ae18a16e11..80ce679496 100644
--- a/guix/build/linux-initrd.scm
+++ b/guix/build/linux-initrd.scm
@@ -19,14 +19,23 @@
 (define-module (guix build linux-initrd)
   #:use-module (rnrs io ports)
   #:use-module (system foreign)
+  #:autoload   (system repl repl) (start-repl)
+  #:autoload   (system base compile) (compile-file)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 ftw)
+  #:use-module (guix build utils)
   #:export (mount-essential-file-systems
             linux-command-line
             make-essential-device-nodes
             configure-qemu-networking
             mount-qemu-smb-share
+            mount-qemu-9p
             bind-mount
             load-linux-module*
-            device-number))
+            device-number
+            boot-system))
 
 ;;; Commentary:
 ;;;
@@ -74,10 +83,26 @@
   (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))
+  ;; Make the device nodes for SCSI disks.
+  (mknod (scope "dev/sda") 'block-special #o644 (device-number 8 0))
+  (mknod (scope "dev/sda1") 'block-special #o644 (device-number 8 1))
+  (mknod (scope "dev/sda2") 'block-special #o644 (device-number 8 2))
+
+  ;; The virtio (para-virtualized) block devices, as supported by QEMU/KVM.
+  (mknod (scope "dev/vda") 'block-special #o644 (device-number 252 0))
+  (mknod (scope "dev/vda1") 'block-special #o644 (device-number 252 1))
+  (mknod (scope "dev/vda2") 'block-special #o644 (device-number 252 2))
+
+  ;; Memory (used by Xorg's VESA driver.)
+  (mknod (scope "dev/mem") 'char-special #o640 (device-number 1 1))
+  (mknod (scope "dev/kmem") 'char-special #o640 (device-number 1 2))
+
+  ;; Inputs (used by Xorg.)
+  (unless (file-exists? (scope "dev/input"))
+    (mkdir (scope "dev/input")))
+  (mknod (scope "dev/input/mice") 'char-special #o640 (device-number 13 63))
+  (mknod (scope "dev/input/mouse0") 'char-special #o640 (device-number 13 32))
+  (mknod (scope "dev/input/event0") 'char-special #o640 (device-number 13 64))
 
   ;; TTYs.
   (mknod (scope "dev/tty") 'char-special #o600
@@ -133,6 +158,17 @@ Vanilla QEMU's `-smb' option just exports a /qemu share, whereas our
     (mount (string-append "//" server share) mount-point "cifs" 0
            (string->pointer "guest,sec=none"))))
 
+(define (mount-qemu-9p source mount-point)
+  "Mount QEMU's 9p file system from SOURCE at MOUNT-POINT.
+
+This uses the 'virtio' transport, which requires the various virtio Linux
+modules to be loaded."
+
+  (format #t "mounting QEMU's 9p share '~a'...\n" source)
+  (let ((server "10.0.2.4"))
+    (mount source mount-point "9p" 0
+           (string->pointer "trans=virtio"))))
+
 (define (bind-mount source target)
   "Bind-mount SOURCE at TARGET."
   (define MS_BIND 4096)                           ; from libc's <sys/mount.h>
@@ -151,4 +187,155 @@ Vanilla QEMU's `-smb' option just exports a /qemu share, whereas our
 the last argument of `mknod'."
   (+ (* major 256) minor))
 
+(define* (boot-system #:key
+                      (linux-modules '())
+                      qemu-guest-networking?
+                      guile-modules-in-chroot?
+                      volatile-root?
+                      (mounts '()))
+  "This procedure is meant to be called from an initrd.  Boot a system by
+first loading LINUX-MODULES, then setting up QEMU guest networking if
+QEMU-GUEST-NETWORKING? is true, 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'.
+
+MOUNTS must be a list of elements of the form:
+
+  (FILE-SYSTEM-TYPE SOURCE TARGET)
+
+When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in
+the new root.
+
+When VOLATILE-ROOT? is true, the root file system is writable but any changes
+to it are lost."
+  (define (resolve file)
+    ;; If FILE is a symlink to an absolute file name, resolve it as if we were
+    ;; under /root.
+    (let ((st (lstat file)))
+      (if (eq? 'symlink (stat:type st))
+          (let ((target (readlink file)))
+            (resolve (string-append "/root" target)))
+          file)))
+
+  (define MS_RDONLY 1)
+
+  (display "Welcome, this is GNU's early boot Guile.\n")
+  (display "Use '--repl' for an initrd REPL.\n\n")
+
+  (mount-essential-file-systems)
+  (let* ((args    (linux-command-line))
+         (option  (lambda (opt)
+                    (let ((opt (string-append opt "=")))
+                      (and=> (find (cut string-prefix? opt <>)
+                                   args)
+                             (lambda (arg)
+                               (substring arg (+ 1 (string-index arg #\=))))))))
+         (to-load (option "--load"))
+         (root    (option "--root")))
+
+    (when (member "--repl" args)
+      (start-repl))
+
+    (display "loading kernel modules...\n")
+    (for-each (compose load-linux-module*
+                       (cut string-append "/modules/" <>))
+              linux-modules)
+
+    (when qemu-guest-networking?
+      (unless (configure-qemu-networking)
+        (display "network interface is DOWN\n")))
+
+    ;; Make /dev nodes.
+    (make-essential-device-nodes)
+
+    ;; Prepare the real root file system under /root.
+    (unless (file-exists? "/root")
+      (mkdir "/root"))
+    (if root
+        (catch #t
+          (lambda ()
+            (if volatile-root?
+                (begin
+                  ;; XXX: For lack of a union file system...
+                  (mkdir-p "/real-root")
+                  (mount root "/real-root" "ext3" MS_RDONLY)
+                  (mount "none" "/root" "tmpfs")
+
+                  ;; XXX: 'copy-recursively' cannot deal with device nodes, so
+                  ;; explicitly avoid /dev.
+                  (for-each (lambda (file)
+                              (unless (string=? "dev" file)
+                                (copy-recursively (string-append "/real-root/"
+                                                                 file)
+                                                  (string-append "/root/"
+                                                                 file)
+                                                  #:log (%make-void-port
+                                                         "w"))))
+                            (scandir "/real-root"
+                                     (lambda (file)
+                                       (not (member file '("." ".."))))))
+
+                  ;; TODO: Unmount /real-root.
+                  )
+                (mount root "/root" "ext3")))
+          (lambda args
+            (format (current-error-port) "exception while mounting '~a': ~s~%"
+                    root args)
+            (start-repl)))
+        (mount "none" "/root" "tmpfs"))
+
+    (mount-essential-file-systems #:root "/root")
+
+    (unless (file-exists? "/root/dev")
+      (mkdir "/root/dev")
+      (make-essential-device-nodes #:root "/root"))
+
+    ;; Mount the specified file systems.
+    (for-each (match-lambda
+               (('cifs source target)
+                (let ((target (string-append "/root/" target)))
+                  (mkdir-p target)
+                  (mount-qemu-smb-share source target)))
+               (('9p source target)
+                (let ((target (string-append "/root/" target)))
+                  (mkdir-p target)
+                  (mount-qemu-9p source target))))
+              mounts)
+
+    (when guile-modules-in-chroot?
+      ;; Copy the directories that contain .scm and .go files so that the
+      ;; child process in the chroot can load modules (we would bind-mount
+      ;; them but for some reason that fails with EINVAL -- XXX).
+      (mkdir-p "/root/share")
+      (mkdir-p "/root/lib")
+      (mount "none" "/root/share" "tmpfs")
+      (mount "none" "/root/lib" "tmpfs")
+      (copy-recursively "/share" "/root/share"
+                        #:log (%make-void-port "w"))
+      (copy-recursively "/lib" "/root/lib"
+                        #:log (%make-void-port "w")))
+
+    (if to-load
+        (begin
+          (format #t "loading '~a'...\n" to-load)
+          (chdir "/root")
+          (chroot "/root")
+          ;; TODO: Remove /lib, /share, and /loader.go.
+          (catch #t
+            (lambda ()
+              (primitive-load to-load))
+            (lambda args
+              (format (current-error-port) "'~a' raised an exception: ~s~%"
+                      to-load args)
+              (start-repl)))
+          (format (current-error-port)
+                  "boot program '~a' terminated, rebooting~%"
+                  to-load)
+          (sleep 2)
+          (reboot))
+        (begin
+          (display "no boot file passed via '--load'\n")
+          (display "entering a warm and cozy REPL\n")
+          (start-repl)))))
+
 ;;; linux-initrd.scm ends here
diff --git a/guix/build/union.scm b/guix/build/union.scm
index 1b09da45c7..6e2b296d81 100644
--- a/guix/build/union.scm
+++ b/guix/build/union.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -103,21 +103,26 @@ single leaf."
       (leaf leaf))))
 
 (define (file=? file1 file2)
-  "Return #t if the contents of FILE1 and FILE2 are identical, #f otherwise."
-  (and (= (stat:size (stat file1)) (stat:size (stat file2)))
-       (call-with-input-file file1
-         (lambda (port1)
-           (call-with-input-file file2
-             (lambda (port2)
-               (define len 8192)
-               (define buf1 (make-bytevector len))
-               (define buf2 (make-bytevector len))
-               (let loop ()
-                 (let ((n1 (get-bytevector-n! port1 buf1 0 len))
-                       (n2 (get-bytevector-n! port2 buf2 0 len)))
-                   (and (equal? n1 n2)
-                        (or (eof-object? n1)
-                            (loop)))))))))))
+  "Return #t if FILE1 and FILE2 are regular files and their contents are
+identical, #f otherwise."
+  (let ((st1 (stat file1))
+        (st2 (stat file2)))
+    (and (eq? (stat:type st1) 'regular)
+         (eq? (stat:type st2) 'regular)
+         (= (stat:size st1) (stat:size st2))
+         (call-with-input-file file1
+           (lambda (port1)
+             (call-with-input-file file2
+               (lambda (port2)
+                 (define len 8192)
+                 (define buf1 (make-bytevector len))
+                 (define buf2 (make-bytevector len))
+                 (let loop ()
+                   (let ((n1 (get-bytevector-n! port1 buf1 0 len))
+                         (n2 (get-bytevector-n! port2 buf2 0 len)))
+                     (and (equal? n1 n2)
+                          (or (eof-object? n1)
+                              (loop))))))))))))
 
 (define* (union-build output directories
                       #:key (log-port (current-error-port)))