Merge branch 'master' into core-updates

9 files changed, 259 insertions, 30 deletions

diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm
index 3347dc502c..76a9a3befe 100644
--- a/guix/build-system/cmake.scm
+++ b/guix/build-system/cmake.scm
@@ -35,13 +35,20 @@
 ;;
 ;; Code:
 
+(define (default-cmake)
+  "Return the default CMake package."
+
+  ;; Do not use `@' to avoid introducing circular dependencies.
+  (let ((module (resolve-interface '(gnu packages cmake))))
+    (module-ref module 'cmake)))
+
 (define* (cmake-build store name source inputs
                      #:key (guile #f)
                      (outputs '("out")) (configure-flags ''())
                      (search-paths '())
                      (make-flags ''())
                      (patches ''()) (patch-flags ''("--batch" "-p1"))
-                     (cmake (@ (gnu packages cmake) cmake))
+                     (cmake (default-cmake))
                      (out-of-source? #f)
                      (tests? #t)
                      (test-target "test")
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  '()))
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 8ddef117d4..c05644add2 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -61,6 +61,8 @@
             derivation
 
             %guile-for-build
+            imported-modules
+            compiled-modules
             build-expression->derivation
             imported-files))
 
@@ -497,12 +499,20 @@ the derivation called NAME with hash HASH."
                   name
                   (string-append name "-" output))))
 
-(define* (derivation store name system builder args env-vars inputs
-                     #:key (outputs '("out")) hash hash-algo hash-mode)
+(define* (derivation store name builder args
+                     #:key
+                     (system (%current-system)) (env-vars '())
+                     (inputs '()) (outputs '("out"))
+                     hash hash-algo hash-mode
+                     references-graphs)
   "Build a derivation with the given arguments.  Return the resulting
 store path and <derivation> object.  When HASH, HASH-ALGO, and HASH-MODE
 are given, a fixed-output derivation is created---i.e., one whose result is
-known in advance, such as a file download."
+known in advance, such as a file download.
+
+When REFERENCES-GRAPHS is true, it must be a list of file name/store path
+pairs.  In that case, the reference graph of each store path is exported in
+the build environment in the corresponding file, in a simple text format."
   (define direct-store-path?
     (let ((len (+ 1 (string-length (%store-prefix)))))
       (lambda (p)
@@ -537,7 +547,22 @@ known in advance, such as a file download."
                                            value))))
                                env-vars))))))
 
-  (define (env-vars-with-empty-outputs)
+  (define (user+system-env-vars)
+    ;; Some options are passed to the build daemon via the env. vars of
+    ;; derivations (urgh!).  We hide that from our API, but here is the place
+    ;; where we kludgify those options.
+    (match references-graphs
+      (((file . path) ...)
+       (let ((value (map (cut string-append <> " " <>)
+                         file path)))
+         ;; XXX: This all breaks down if an element of FILE or PATH contains
+         ;; white space.
+         `(("exportReferencesGraph" . ,(string-join value " "))
+           ,@env-vars)))
+      (#f
+       env-vars)))
+
+  (define (env-vars-with-empty-outputs env-vars)
     ;; Return a variant of ENV-VARS where each OUTPUTS is associated with an
     ;; empty string, even outputs that do not appear in ENV-VARS.
     (let ((e (map (match-lambda
@@ -569,7 +594,7 @@ known in advance, such as a file download."
                                                       #t "sha256" input)))
                               (make-derivation-input path '()))))
                           (delete-duplicates inputs)))
-         (env-vars   (env-vars-with-empty-outputs))
+         (env-vars   (env-vars-with-empty-outputs (user+system-env-vars)))
          (drv-masked (make-derivation outputs
                                       (filter (compose derivation-path?
                                                        derivation-input-path)
@@ -720,7 +745,8 @@ they can refer to each other."
                                        hash hash-algo
                                        (env-vars '())
                                        (modules '())
-                                       guile-for-build)
+                                       guile-for-build
+                                       references-graphs)
   "Return a derivation that executes Scheme expression EXP as a builder
 for derivation NAME.  INPUTS must be a list of (NAME DRV-PATH SUB-DRV)
 tuples; when SUB-DRV is omitted, \"out\" is assumed.  MODULES is a list
@@ -737,7 +763,9 @@ builder terminates by passing the result of EXP to `exit'; thus, when
 EXP returns #f, the build is considered to have failed.
 
 EXP is built using GUILE-FOR-BUILD (a derivation).  When GUILE-FOR-BUILD is
-omitted or is #f, the value of the `%guile-for-build' fluid is used instead."
+omitted or is #f, the value of the `%guile-for-build' fluid is used instead.
+
+See the `derivation' procedure for the meaning of REFERENCES-GRAPHS."
   (define guile-drv
     (or guile-for-build (%guile-for-build)))
 
@@ -747,8 +775,8 @@ omitted or is #f, the value of the `%guile-for-build' fluid is used instead."
 
   (define module-form?
     (match-lambda
-      (((or 'define-module 'use-modules) _ ...) #t)
-      (_ #f)))
+     (((or 'define-module 'use-modules) _ ...) #t)
+     (_ #f)))
 
   (define source-path
     ;; When passed an input that is a source, return its path; otherwise
@@ -833,22 +861,26 @@ omitted or is #f, the value of the `%guile-for-build' fluid is used instead."
                                           #:system system)))
          (go-dir   (and go-drv
                         (derivation-path->output-path go-drv))))
-    (derivation store name system guile
+    (derivation store name guile
                 `("--no-auto-compile"
                   ,@(if mod-dir `("-L" ,mod-dir) '())
                   ,builder)
 
+                #:system system
+
+                #:inputs `((,(or guile-for-build (%guile-for-build)))
+                           (,builder)
+                           ,@(map cdr inputs)
+                           ,@(if mod-drv `((,mod-drv) (,go-drv)) '()))
+
                 ;; When MODULES is non-empty, shamelessly clobber
                 ;; $GUILE_LOAD_COMPILED_PATH.
-                (if go-dir
-                    `(("GUILE_LOAD_COMPILED_PATH" . ,go-dir)
-                      ,@(alist-delete "GUILE_LOAD_COMPILED_PATH"
-                                      env-vars))
-                    env-vars)
-
-                `((,(or guile-for-build (%guile-for-build)))
-                  (,builder)
-                  ,@(map cdr inputs)
-                  ,@(if mod-drv `((,mod-drv) (,go-drv)) '()))
+                #:env-vars (if go-dir
+                               `(("GUILE_LOAD_COMPILED_PATH" . ,go-dir)
+                                 ,@(alist-delete "GUILE_LOAD_COMPILED_PATH"
+                                                 env-vars))
+                               env-vars)
+
                 #:hash hash #:hash-algo hash-algo
-                #:outputs outputs)))
+                #:outputs outputs
+                #:references-graphs references-graphs)))
diff --git a/guix/download.scm b/guix/download.scm
index b12659f683..fa76615ef2 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -99,7 +99,9 @@
        "http://ramses.wh2.tu-dresden.de/pub/mirrors/kernel.org/"
        "http://linux-kernel.uio.no/pub/"
        "http://kernel.osuosl.org/pub/"
-       "ftp://ftp.funet.fi/pub/mirrors/ftp.kernel.org/pub/")
+       "ftp://ftp.funet.fi/pub/mirrors/ftp.kernel.org/pub/"
+       "http://ftp.be.debian.org/pub/"
+       "http://mirror.linux.org.au/")
       (apache             ; from http://www.apache.org/mirrors/dist.html
        "http://www.eu.apache.org/dist/"
        "http://www.us.apache.org/dist/"
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index f4135efc99..f3d87a63c0 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -106,6 +106,8 @@ files."
                      (when (string-suffix? ".scm" file)
                        (let ((go (string-append (string-drop-right file 4)
                                                 ".go")))
+                         (format (current-error-port)
+                                 "compiling '~a'...~%" file)
                          (compile-file file
                                        #:output-file go
                                        #:opts %auto-compilation-options))))
@@ -114,7 +116,9 @@ files."
                    ;; download), we must build it first to avoid errors since
                    ;; (gnutls) is unavailable.
                    (cons (string-append out "/guix/build/download.scm")
-                         (find-files out "\\.scm")))
+
+                         ;; Sort the file names to get deterministic results.
+                         (sort (find-files out "\\.scm") string<?)))
 
          ;; Remove the "fake" (guix config).
          (delete-file (string-append out "/guix/config.scm"))
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 97bbfcbce8..63f0c4f8d2 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -508,8 +508,13 @@ PORT.  REPORT-PROGRESS is a two-argument procedure such as that returned by
         ;; Tell the daemon what the expected hash of the Nar itself is.
         (format #t "~a~%" (narinfo-hash narinfo))
 
-        (format (current-error-port) "downloading `~a' from `~a'...~%"
-                store-path (uri->string uri))
+        (format (current-error-port) "downloading `~a' from `~a'~:[~*~; (~,1f MiB installed)~]...~%"
+                store-path (uri->string uri)
+
+                ;; Use the Nar size as an estimate of the installed size.
+                (narinfo-size narinfo)
+                (and=> (narinfo-size narinfo)
+                       (cute / <> (expt 2. 20))))
         (let*-values (((raw download-size)
                        ;; Note that Hydra currently generates Nars on the fly
                        ;; and doesn't specify a Content-Length, so
diff --git a/guix/store.scm b/guix/store.scm
index 343da91506..541c7c848f 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -25,6 +25,7 @@
   #:use-module (rnrs io ports)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
@@ -242,6 +243,14 @@
   (ats-cache  nix-server-add-to-store-cache)
   (atts-cache nix-server-add-text-to-store-cache))
 
+(set-record-type-printer! <nix-server>
+                          (lambda (obj port)
+                            (format port "#<build-daemon ~a.~a ~a>"
+                                    (nix-server-major-version obj)
+                                    (nix-server-minor-version obj)
+                                    (number->string (object-address obj)
+                                                    16))))
+
 (define-condition-type &nix-error &error
   nix-error?)
 
diff --git a/guix/ui.scm b/guix/ui.scm
index 9251d73f18..720d01be02 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -242,6 +242,7 @@ available for download."
                                        (substitutable-path-info store
                                                                 download)))))
                      download)))
+    ;; TODO: Show the installed size of DOWNLOAD.
     (if dry-run?
         (begin
           (format (current-error-port)