Merge branch 'master' into core-updates

27 files changed, 1665 insertions, 424 deletions

diff --git a/guix/build/activation.scm b/guix/build/activation.scm
new file mode 100644
index 0000000000..62e69a9152
--- /dev/null
+++ b/guix/build/activation.scm
@@ -0,0 +1,219 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 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 activation)
+  #:use-module (guix build utils)
+  #:use-module (guix build linux-initrd)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:export (activate-users+groups
+            activate-etc
+            activate-setuid-programs
+            activate-current-system))
+
+;;; Commentary:
+;;;
+;;; This module provides "activation" helpers.  Activation is the process that
+;;; consists in setting up system-wide files and directories so that an
+;;; 'operating-system' configuration becomes active.
+;;;
+;;; Code:
+
+(define* (add-group name #:key gid password
+                    (log-port (current-error-port)))
+  "Add NAME as a user group, with the given numeric GID if specified."
+  ;; Use 'groupadd' from the Shadow package.
+  (format log-port "adding group '~a'...~%" name)
+  (let ((args `(,@(if gid `("-g" ,(number->string gid)) '())
+                ,@(if password `("-p" ,password) '())
+                ,name)))
+    (zero? (apply system* "groupadd" args))))
+
+(define* (add-user name group
+                   #:key uid comment home shell password
+                   (supplementary-groups '())
+                   (log-port (current-error-port)))
+  "Create an account for user NAME part of GROUP, with the specified
+properties.  Return #t on success."
+  (format log-port "adding user '~a'...~%" name)
+
+  (if (and uid (zero? uid))
+
+      ;; 'useradd' fails with "Cannot determine your user name" if the root
+      ;; account doesn't exist.  Thus, for bootstrapping purposes, create that
+      ;; one manually.
+      (begin
+        (call-with-output-file "/etc/shadow"
+          (cut format <> "~a::::::::~%" name))
+        (call-with-output-file "/etc/passwd"
+          (cut format <> "~a:x:~a:~a:~a:~a:~a~%"
+               name "0" "0" comment home shell))
+        (chmod "/etc/shadow" #o600)
+        #t)
+
+      ;; Use 'useradd' from the Shadow package.
+      (let ((args `(,@(if uid `("-u" ,(number->string uid)) '())
+                    "-g" ,(if (number? group) (number->string group) group)
+                    ,@(if (pair? supplementary-groups)
+                          `("-G" ,(string-join supplementary-groups ","))
+                          '())
+                    ,@(if comment `("-c" ,comment) '())
+                    ,@(if home
+                          (if (file-exists? home)
+                              `("-d" ,home)     ; avoid warning from 'useradd'
+                              `("-d" ,home "--create-home"))
+                          '())
+                    ,@(if shell `("-s" ,shell) '())
+                    ,@(if password `("-p" ,password) '())
+                    ,name)))
+        (zero? (apply system* "useradd" args)))))
+
+(define (activate-users+groups users groups)
+  "Make sure the accounts listed in USERS and the user groups listed in GROUPS
+are all available.
+
+Each item in USERS is a list of all the characteristics of a user account;
+each item in GROUPS is a tuple with the group name, group password or #f, and
+numeric gid or #f."
+  (define (touch file)
+    (call-with-output-file file (const #t)))
+
+  (define activate-user
+    (match-lambda
+     ((name uid group supplementary-groups comment home shell password)
+      (unless (false-if-exception (getpwnam name))
+        (let ((profile-dir (string-append "/var/guix/profiles/per-user/"
+                                          name)))
+          (add-user name group
+                    #:uid uid
+                    #:supplementary-groups supplementary-groups
+                    #:comment comment
+                    #:home home
+                    #:shell shell
+                    #:password password)
+
+          ;; Create the profile directory for the new account.
+          (let ((pw (getpwnam name)))
+            (mkdir-p profile-dir)
+            (chown profile-dir (passwd:uid pw) (passwd:gid pw))))))))
+
+  ;; 'groupadd' aborts if the file doesn't already exist.
+  (touch "/etc/group")
+
+  ;; Create the root account so we can use 'useradd' and 'groupadd'.
+  (activate-user (find (match-lambda
+                        ((name (? zero?) _ ...) #t)
+                        (_ #f))
+                       users))
+
+  ;; Then create the groups.
+  (for-each (match-lambda
+             ((name password gid)
+              (add-group name #:gid gid #:password password)))
+            groups)
+
+  ;; Finally create the other user accounts.
+  (for-each activate-user users))
+
+(define (activate-etc etc)
+  "Install ETC, a directory in the store, as the source of static files for
+/etc."
+
+  ;; /etc is a mixture of static and dynamic settings.  Here is where we
+  ;; initialize it from the static part.
+
+  (format #t "populating /etc from ~a...~%" etc)
+  (let ((rm-f (lambda (f)
+                (false-if-exception (delete-file f)))))
+    (rm-f "/etc/static")
+    (symlink etc "/etc/static")
+    (for-each (lambda (file)
+                ;; TODO: Handle 'shadow' specially so that changed
+                ;; password aren't lost.
+                (let ((target (string-append "/etc/" file))
+                      (source (string-append "/etc/static/" file)))
+                  (rm-f target)
+                  (symlink source target)))
+              (scandir etc
+                       (lambda (file)
+                         (not (member file '("." ".."))))
+
+                       ;; 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")))
+
+(define %setuid-directory
+  ;; Place where setuid programs are stored.
+  "/run/setuid-programs")
+
+(define (activate-setuid-programs programs)
+  "Turn PROGRAMS, a list of file names, into setuid programs stored under
+%SETUID-DIRECTORY."
+  (define (make-setuid-program prog)
+    (let ((target (string-append %setuid-directory
+                                 "/" (basename prog))))
+      (catch 'system-error
+        (lambda ()
+          (link prog target))
+        (lambda args
+          ;; Perhaps PROG and TARGET live in a different file system, so copy
+          ;; PROG.
+          (copy-file prog target)))
+      (chown target 0 0)
+      (chmod target #o6555)))
+
+  (format #t "setting up setuid programs in '~a'...~%"
+          %setuid-directory)
+  (if (file-exists? %setuid-directory)
+      (for-each (compose delete-file
+                         (cut string-append %setuid-directory "/" <>))
+                (scandir %setuid-directory
+                         (lambda (file)
+                           (not (member file '("." ".."))))
+                         string<?))
+      (mkdir-p %setuid-directory))
+
+  (for-each make-setuid-program programs))
+
+(define %current-system
+  ;; The system that is current (a symlink.)  This is not necessarily the same
+  ;; as the system we booted (aka. /run/booted-system) because we can re-build
+  ;; a new system configuration and activate it, without rebooting.
+  "/run/current-system")
+
+(define (boot-time-system)
+  "Return the '--system' argument passed on the kernel command line."
+  (find-long-option "--system" (linux-command-line)))
+
+(define* (activate-current-system #:optional (system (boot-time-system)))
+  "Atomically make SYSTEM the current system."
+  (format #t "making '~a' the current system...~%" system)
+
+  ;; Atomically make SYSTEM current.
+  (let ((new (string-append %current-system ".new")))
+    (symlink system new)
+    (rename-file new %current-system)))
+
+;;; activation.scm ends here
diff --git a/guix/build/cmake-build-system.scm b/guix/build/cmake-build-system.scm
index 75998568bc..144552e8de 100644
--- a/guix/build/cmake-build-system.scm
+++ b/guix/build/cmake-build-system.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com>
+;;; Copyright © 2014 Andreas Enge <andreas@enge.fr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -48,6 +49,10 @@
 
     (let ((args `(,srcdir
                   ,(string-append "-DCMAKE_INSTALL_PREFIX=" out)
+                  ;; add input libraries to rpath
+                  "-DCMAKE_INSTALL_RPATH_USE_LINK_PATH=TRUE"
+                  ;; add (other) libraries of the project itself to rpath
+                  ,(string-append "-DCMAKE_INSTALL_RPATH=" out "/lib")
                   ,@configure-flags)))
       (setenv "CMAKE_LIBRARY_PATH" (getenv "LIBRARY_PATH"))
       (setenv "CMAKE_INCLUDE_PATH" (getenv "CPATH"))
diff --git a/guix/build/download.scm b/guix/build/download.scm
index 54115a9de2..d98933a907 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -167,8 +167,6 @@ which is not available during bootstrap."
 
           ;; Buffer input and output on this port.
           (setvbuf s _IOFBF)
-          ;; Enlarge the receive buffer.
-          (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024))
 
           (if (eq? 'https (uri-scheme uri))
               (tls-wrap s)
@@ -307,7 +305,10 @@ on success."
                uri)
        #f)))
 
-  (setvbuf (current-output-port) _IOLBF)
+  ;; Make this unbuffered so 'progress-proc' works as expected.  _IOLBF means
+  ;; '\n', not '\r', so it's not appropriate here.
+  (setvbuf (current-output-port) _IONBF)
+
   (setvbuf (current-error-port) _IOLBF)
 
   (let try ((uri uri))
diff --git a/guix/build/git.scm b/guix/build/git.scm
index 4245594c38..68b132265b 100644
--- a/guix/build/git.scm
+++ b/guix/build/git.scm
@@ -31,6 +31,11 @@
                     #:key (git-command "git"))
   "Fetch COMMIT from URL into DIRECTORY.  COMMIT must be a valid Git commit
 identifier.  Return #t on success, #f otherwise."
+
+  ;; Disable TLS certificate verification.  The hash of the checkout is known
+  ;; in advance anyway.
+  (setenv "GIT_SSL_NO_VERIFY" "true")
+
   (and (zero? (system* git-command "clone" url directory))
        (with-directory-excursion directory
          (system* git-command "tag" "-l")
diff --git a/guix/build/gnome.scm b/guix/build/gnome.scm
deleted file mode 100644
index cac4de8f24..0000000000
--- a/guix/build/gnome.scm
+++ /dev/null
@@ -1,31 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com>
-;;;
-;;; 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 gnome)
-  #:export (gir-directory))
-
-;;; Commentary:
-;;;
-;;; Tools commonly used when building GNOME programs.
-;;;
-;;; Code:
-
-(define (gir-directory inputs pkg-name)
-  "Return the GIR directory name for PKG-NAME found from INPUTS."
-  (string-append (assoc-ref inputs pkg-name)
-                 "/share/gir-1.0"))
diff --git a/guix/build/install.scm b/guix/build/install.scm
new file mode 100644
index 0000000000..afa7d1dd8f
--- /dev/null
+++ b/guix/build/install.scm
@@ -0,0 +1,122 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 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 install)
+  #:use-module (guix build utils)
+  #:use-module (guix build install)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 match)
+  #:export (install-grub
+            populate-root-file-system
+            reset-timestamps
+            register-closure))
+
+;;; Commentary:
+;;;
+;;; This module supports the installation of the GNU system on a hard disk.
+;;; It is meant to be used both in a build environment (in derivations that
+;;; build VM images), and on the bare metal (when really installing the
+;;; system.)
+;;;
+;;; Code:
+
+(define* (install-grub grub.cfg device mount-point)
+  "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on
+MOUNT-POINT."
+  (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-file grub.cfg pivot)
+    (rename-file pivot target)
+
+    (unless (zero? (system* "grub-install" "--no-floppy"
+                            "--boot-directory"
+                            (string-append mount-point "/boot")
+                            device))
+      (error "failed to install GRUB"))))
+
+(define (evaluate-populate-directive directive target)
+  "Evaluate DIRECTIVE, an sexp describing a file or directory to create under
+directory TARGET."
+  (let loop ((directive directive))
+    (match directive
+      (('directory name)
+       (mkdir-p (string-append target name)))
+      (('directory name uid gid)
+       (let ((dir (string-append target name)))
+         (mkdir-p dir)
+         (chown dir uid gid)))
+      (('directory name uid gid mode)
+       (loop `(directory ,name ,uid ,gid))
+       (chmod (string-append target name) mode))
+      ((new '-> old)
+       (symlink old (string-append target new))))))
+
+(define (directives store)
+  "Return a list of directives to populate the root file system that will host
+STORE."
+  `((directory ,store 0 0)
+    (directory "/etc")
+    (directory "/var/log")                          ; for dmd
+    (directory "/var/guix/gcroots")
+    (directory "/var/empty")                        ; for no-login accounts
+    (directory "/var/run")
+    (directory "/run")
+    ("/var/guix/gcroots/booted-system" -> "/run/booted-system")
+    ("/var/guix/gcroots/current-system" -> "/run/current-system")
+    (directory "/bin")
+    ("/bin/sh" -> "/run/current-system/profile/bin/bash")
+    (directory "/tmp" 0 0 #o1777)                 ; sticky bit
+    (directory "/var/guix/profiles/per-user/root" 0 0)
+
+    (directory "/root" 0 0)                       ; an exception
+    (directory "/home" 0 0)))
+
+(define (populate-root-file-system target)
+  "Make the essential non-store files and directories on TARGET.  This
+includes /etc, /var, /run, /bin/sh, etc."
+  (for-each (cut evaluate-populate-directive <> target)
+            (directives (%store-directory))))
+
+(define (reset-timestamps directory)
+  "Reset the timestamps of all the files under DIRECTORY, so that they appear
+as created and modified at the Epoch."
+  (display "clearing file timestamps...\n")
+  (for-each (lambda (file)
+              (let ((s (lstat file)))
+                ;; XXX: Guile uses libc's 'utime' function (not 'futime'), so
+                ;; the timestamp of symlinks cannot be changed, and there are
+                ;; symlinks here pointing to /gnu/store, which is the host,
+                ;; read-only store.
+                (unless (eq? (stat:type s) 'symlink)
+                  (utime file 0 0 0 0))))
+            (find-files directory "")))
+
+(define (register-closure store closure)
+  "Register CLOSURE in STORE, where STORE is the directory name of the target
+store and CLOSURE is the name of a file containing a reference graph as used
+by 'guix-register'.  As a side effect, this resets timestamps on store files."
+  (let ((status (system* "guix-register" "--prefix" store
+                         closure)))
+    (unless (zero? status)
+      (error "failed to register store items" closure))))
+
+;;; install.scm ends here
diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm
index 61d4304b65..5be3c1ac2a 100644
--- a/guix/build/linux-initrd.scm
+++ b/guix/build/linux-initrd.scm
@@ -28,10 +28,11 @@
   #:use-module (guix build utils)
   #:export (mount-essential-file-systems
             linux-command-line
+            find-long-option
             make-essential-device-nodes
             configure-qemu-networking
-            mount-qemu-smb-share
-            mount-qemu-9p
+            check-file-system
+            mount-file-system
             bind-mount
             load-linux-module*
             device-number
@@ -63,12 +64,30 @@
     (mkdir (scope "sys")))
   (mount "none" (scope "sys") "sysfs"))
 
+(define (move-essential-file-systems root)
+  "Move currently mounted essential file systems to ROOT."
+  (for-each (lambda (dir)
+              (let ((target (string-append root dir)))
+                (unless (file-exists? target)
+                  (mkdir target))
+                (mount dir target "" MS_MOVE)))
+            '("/proc" "/sys")))
+
 (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 (find-long-option option arguments)
+  "Find OPTION among ARGUMENTS, where OPTION is something like \"--load\".
+Return the value associated with OPTION, or #f on failure."
+  (let ((opt (string-append option "=")))
+    (and=> (find (cut string-prefix? opt <>)
+                 arguments)
+           (lambda (arg)
+             (substring arg (+ 1 (string-index arg #\=)))))))
+
 (define* (make-essential-device-nodes #:key (root "/"))
   "Make essential device nodes under ROOT/dev."
   ;; The hand-made udev!
@@ -115,6 +134,10 @@
                   (device-number 4 n))
            (loop (+ 1 n)))))
 
+  ;; Serial line.
+  (mknod (scope "dev/ttyS0") 'char-special #o660
+         (device-number 4 64))
+
   ;; Pseudo ttys.
   (mknod (scope "dev/ptmx") 'char-special #o666
          (device-number 5 2))
@@ -143,7 +166,18 @@
   (symlink "/proc/self/fd" (scope "dev/fd"))
   (symlink "/proc/self/fd/0" (scope "dev/stdin"))
   (symlink "/proc/self/fd/1" (scope "dev/stdout"))
-  (symlink "/proc/self/fd/2" (scope "dev/stderr")))
+  (symlink "/proc/self/fd/2" (scope "dev/stderr"))
+
+  ;; Loopback devices.
+  (let loop ((i 0))
+    (when (< i 8)
+      (mknod (scope (string-append "dev/loop" (number->string i)))
+             'block-special #o660
+             (device-number 7 i))
+      (loop (+ 1 i))))
+
+  ;; File systems in user space (FUSE).
+  (mknod (scope "dev/fuse") 'char-special #o666 (device-number 10 229)))
 
 (define %host-qemu-ipv4-address
   (inet-pton AF_INET "10.0.2.10"))
@@ -167,33 +201,13 @@ networking values.)  Return #t if INTERFACE is up, #f otherwise."
 
     (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 (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"))))
+;; Linux mount flags, from libc's <sys/mount.h>.
+(define MS_RDONLY 1)
+(define MS_BIND 4096)
+(define MS_MOVE 8192)
 
 (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)
@@ -208,6 +222,165 @@ modules to be loaded."
 the last argument of `mknod'."
   (+ (* major 256) minor))
 
+(define (pidof program)
+  "Return the PID of the first presumed instance of PROGRAM."
+  (let ((program (basename program)))
+    (find (lambda (pid)
+            (let ((exe (format #f "/proc/~a/exe" pid)))
+              (and=> (false-if-exception (readlink exe))
+                     (compose (cut string=? program <>) basename))))
+          (filter-map string->number (scandir "/proc")))))
+
+(define* (mount-root-file-system root type
+                                 #:key volatile-root? (unionfs "unionfs"))
+  "Mount the root file system of type TYPE at device ROOT.  If VOLATILE-ROOT?
+is true, mount ROOT read-only and make it a union with a writable tmpfs using
+UNIONFS."
+  (define (mark-as-not-killable pid)
+    ;; Tell the 'user-processes' dmd service that PID must be kept alive when
+    ;; shutting down.
+    (mkdir-p "/root/etc/dmd")
+    (let ((port (open-file "/root/etc/dmd/do-not-kill" "a")))
+      (chmod port #o600)
+      (write pid port)
+      (newline port)
+      (close-port port)))
+
+  (catch #t
+    (lambda ()
+      (if volatile-root?
+          (begin
+            (mkdir-p "/real-root")
+            (mount root "/real-root" type MS_RDONLY)
+            (mkdir-p "/rw-root")
+            (mount "none" "/rw-root" "tmpfs")
+
+            ;; We want read-write /dev nodes.
+            (make-essential-device-nodes #:root "/rw-root")
+
+            ;; Make /root a union of the tmpfs and the actual root.
+            (unless (zero? (system* unionfs "-o"
+                                    "cow,allow_other,use_ino,suid,dev"
+                                    "/rw-root=RW:/real-root=RO"
+                                    "/root"))
+              (error "unionfs failed"))
+
+            ;; Make sure unionfs remains alive till the end.  Because
+            ;; 'fuse_daemonize' doesn't tell the PID of the forked daemon, we
+            ;; have to resort to 'pidof' here.
+            (mark-as-not-killable (pidof unionfs)))
+          (begin
+            (check-file-system root type)
+            (mount root "/root" type))))
+    (lambda args
+      (format (current-error-port) "exception while mounting '~a': ~s~%"
+              root args)
+      (start-repl)))
+
+  (copy-file "/proc/mounts" "/root/etc/mtab"))
+
+(define (check-file-system device type)
+  "Run a file system check of TYPE on DEVICE."
+  (define fsck
+    (string-append "fsck." type))
+
+  (let ((status (system* fsck "-v" "-p" device)))
+    (match (status:exit-val status)
+      (0
+       #t)
+      (1
+       (format (current-error-port) "'~a' corrected errors on ~a; continuing~%"
+               fsck device))
+      (2
+       (format (current-error-port) "'~a' corrected errors on ~a; rebooting~%"
+               fsck device)
+       (sleep 3)
+       (reboot))
+      (code
+       (format (current-error-port) "'~a' exited with code ~a on ~a; spawning REPL~%"
+               fsck code device)
+       (start-repl)))))
+
+(define* (mount-file-system spec #:key (root "/root"))
+  "Mount the file system described by SPEC under ROOT.  SPEC must have the
+form:
+
+  (DEVICE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
+
+DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
+FLAGS must be a list of symbols.  CHECK? is a Boolean indicating whether to
+run a file system check."
+  (define flags->bit-mask
+    (match-lambda
+     (('read-only rest ...)
+      (or MS_RDONLY (flags->bit-mask rest)))
+     (('bind-mount rest ...)
+      (or MS_BIND (flags->bit-mask rest)))
+     (()
+      0)))
+
+  (match spec
+    ((source mount-point type (flags ...) options check?)
+     (let ((mount-point (string-append root "/" mount-point)))
+       (when check?
+         (check-file-system source type))
+       (mkdir-p mount-point)
+       (mount source mount-point type (flags->bit-mask flags)
+              (if options
+                  (string->pointer options)
+                  %null-pointer))
+
+       ;; Update /etc/mtab.
+       (mkdir-p (string-append root "/etc"))
+       (let ((port (open-file (string-append root "/etc/mtab") "a")))
+         (format port "~a ~a ~a ~a 0 0~%"
+                 source mount-point type options)
+         (close-port port))))))
+
+(define (switch-root root)
+  "Switch to ROOT as the root file system, in a way similar to what
+util-linux' switch_root(8) does."
+  (move-essential-file-systems root)
+  (chdir root)
+
+  ;; Since we're about to 'rm -rf /', try to make sure we're on an initrd.
+  ;; TODO: Use 'statfs' to check the fs type, like klibc does.
+  (when (or (not (file-exists? "/init")) (directory-exists? "/home"))
+    (format (current-error-port)
+            "The root file system is probably not an initrd; \
+bailing out.~%root contents: ~s~%" (scandir "/"))
+    (force-output (current-error-port))
+    (exit 1))
+
+  ;; Delete files from the old root, without crossing mount points (assuming
+  ;; there are no mount points in sub-directories.)  That means we're leaving
+  ;; the empty ROOT directory behind us, but that's OK.
+  (let ((root-device (stat:dev (stat "/"))))
+    (for-each (lambda (file)
+                (unless (member file '("." ".."))
+                  (let* ((file   (string-append "/" file))
+                         (device (stat:dev (lstat file))))
+                    (when (= device root-device)
+                      (delete-file-recursively file)))))
+              (scandir "/")))
+
+  ;; Make ROOT the new root.
+  (mount root "/" "" MS_MOVE)
+  (chroot ".")
+  (chdir "/")
+
+  (when (file-exists? "/dev/console")
+    ;; Close the standard file descriptors since they refer to the old
+    ;; /dev/console, and reopen them.
+    (let ((console (open-file "/dev/console" "r+b0")))
+      (for-each close-fdes '(0 1 2))
+
+      (dup2 (fileno console) 0)
+      (dup2 (fileno console) 1)
+      (dup2 (fileno console) 2)
+
+      (close-port console))))
+
 (define* (boot-system #:key
                       (linux-modules '())
                       qemu-guest-networking?
@@ -220,9 +393,10 @@ 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:
+Mount the root file system, specified by the '--root' command-line argument,
+if any.
 
-  (FILE-SYSTEM-TYPE SOURCE TARGET)
+MOUNTS must be a list suitable for 'mount-file-system'.
 
 When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in
 the new root.
@@ -238,21 +412,25 @@ to it are lost."
             (resolve (string-append "/root" target)))
           file)))
 
-  (define MS_RDONLY 1)
+  (define root-mount-point?
+    (match-lambda
+     ((device "/" _ ...) #t)
+     (_ #f)))
+
+  (define root-fs-type
+    (or (any (match-lambda
+              ((device "/" type _ ...) type)
+              (_ #f))
+             mounts)
+        "ext4"))
 
   (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")))
+         (to-load (find-long-option "--load" args))
+         (root    (find-long-option "--root" args)))
 
     (when (member "--repl" args)
       (start-repl))
@@ -273,55 +451,17 @@ to it are lost."
     (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-root-file-system root root-fs-type
+                                #:volatile-root? volatile-root?)
         (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)
+    (for-each mount-file-system
+              (remove root-mount-point? mounts))
 
     (when guile-modules-in-chroot?
       ;; Copy the directories that contain .scm and .go files so that the
@@ -338,9 +478,8 @@ to it are lost."
 
     (if to-load
         (begin
+          (switch-root "/root")
           (format #t "loading '~a'...\n" to-load)
-          (chdir "/root")
-          (chroot "/root")
 
           ;; Obviously this has to be done each time we boot.  Do it from here
           ;; so that statfs(2) returns DEVPTS_SUPER_MAGIC like libc's getpt(3)
@@ -352,9 +491,11 @@ to it are lost."
             (lambda ()
               (primitive-load to-load))
             (lambda args
+              (start-repl))
+            (lambda args
               (format (current-error-port) "'~a' raised an exception: ~s~%"
                       to-load args)
-              (start-repl)))
+              (display-backtrace (make-stack #t) (current-error-port))))
           (format (current-error-port)
                   "boot program '~a' terminated, rebooting~%"
                   to-load)
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
new file mode 100644
index 0000000000..7a1bad7331
--- /dev/null
+++ b/guix/build/syscalls.scm
@@ -0,0 +1,183 @@
+;;; 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 syscalls)
+  #:use-module (system foreign)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 ftw)
+  #:export (errno
+            MS_RDONLY
+            MS_REMOUNT
+            MS_BIND
+            MS_MOVE
+            mount
+            umount
+            processes))
+
+;;; Commentary:
+;;;
+;;; This module provides bindings to libc's syscall wrappers.  It uses the
+;;; FFI, and thus requires a dynamically-linked Guile.  (For statically-linked
+;;; Guile, we instead apply 'guile-linux-syscalls.patch'.)
+;;;
+;;; Code:
+
+(define %libc-errno-pointer
+  ;; Glibc's 'errno' pointer.
+  (let ((errno-loc (dynamic-func "__errno_location" (dynamic-link))))
+    (and errno-loc
+         (let ((proc (pointer->procedure '* errno-loc '())))
+           (proc)))))
+
+(define errno
+  (if %libc-errno-pointer
+      (let ((bv (pointer->bytevector %libc-errno-pointer (sizeof int))))
+        (lambda ()
+          "Return the current errno."
+          ;; XXX: We assume that nothing changes 'errno' while we're doing all this.
+          ;; In particular, that means that no async must be running here.
+
+          ;; Use one of the fixed-size native-ref procedures because they are
+          ;; optimized down to a single VM instruction, which reduces the risk
+          ;; that we fiddle with 'errno' (needed on Guile 2.0.5, libc 2.11.)
+          (let-syntax ((ref (lambda (s)
+                              (syntax-case s ()
+                                ((_ bv)
+                                 (case (sizeof int)
+                                   ((4)
+                                    #'(bytevector-s32-native-ref bv 0))
+                                   ((8)
+                                    #'(bytevector-s64-native-ref bv 0))
+                                   (else
+                                    (error "unsupported 'int' size"
+                                           (sizeof int)))))))))
+            (ref bv))))
+      (lambda () 0)))
+
+(define (augment-mtab source target type options)
+  "Augment /etc/mtab with information about the given mount point."
+  (let ((port (open-file "/etc/mtab" "a")))
+    (format port "~a ~a ~a ~a 0 0~%"
+            source target type (or options "rw"))
+    (close-port port)))
+
+(define (read-mtab port)
+  "Read an mtab-formatted file from PORT, returning a list of tuples."
+  (let loop ((result '()))
+    (let ((line (read-line port)))
+      (if (eof-object? line)
+          (reverse result)
+          (loop (cons (string-tokenize line) result))))))
+
+(define (remove-from-mtab target)
+  "Remove mount point TARGET from /etc/mtab."
+  (define entries
+    (remove (match-lambda
+             ((device mount-point type options freq passno)
+              (string=? target mount-point))
+             (_ #f))
+            (call-with-input-file "/etc/fstab" read-mtab)))
+
+  (call-with-output-file "/etc/fstab"
+    (lambda (port)
+      (for-each (match-lambda
+                 ((device mount-point type options freq passno)
+                  (format port "~a ~a ~a ~a ~a ~a~%"
+                          device mount-point type options freq passno)))
+                entries))))
+
+;; Linux mount flags, from libc's <sys/mount.h>.
+(define MS_RDONLY      1)
+(define MS_REMOUNT    32)
+(define MS_BIND     4096)
+(define MS_MOVE     8192)
+
+(define mount
+  (let* ((ptr  (dynamic-func "mount" (dynamic-link)))
+         (proc (pointer->procedure int ptr `(* * * ,unsigned-long *))))
+    (lambda* (source target type #:optional (flags 0) options
+                     #:key (update-mtab? #t))
+      "Mount device SOURCE on TARGET as a file system TYPE.  Optionally, FLAGS
+may be a bitwise-or of the MS_* <sys/mount.h> constants, and OPTIONS may be a
+string.  When FLAGS contains MS_REMOUNT, SOURCE and TYPE are ignored.  When
+UPDATE-MTAB? is true, update /etc/mtab.  Raise a 'system-error' exception on
+error."
+      (let ((ret (proc (if source
+                           (string->pointer source)
+                           %null-pointer)
+                       (string->pointer target)
+                       (if type
+                           (string->pointer type)
+                           %null-pointer)
+                       flags
+                       (if options
+                           (string->pointer options)
+                           %null-pointer)))
+            (err (errno)))
+        (unless (zero? ret)
+          (throw 'system-error "mount" "mount ~S on ~S: ~A"
+                 (list source target (strerror err))
+                 (list err)))
+        (when update-mtab?
+          (augment-mtab source target type options))))))
+
+(define umount
+  (let* ((ptr  (dynamic-func "umount2" (dynamic-link)))
+         (proc (pointer->procedure int ptr `(* ,int))))
+    (lambda* (target #:optional (flags 0)
+                     #:key (update-mtab? #t))
+      "Unmount TARGET.  Optionally FLAGS may be one of the MNT_* or UMOUNT_*
+constants from <sys/mount.h>."
+      (let ((ret (proc (string->pointer target) flags))
+            (err (errno)))
+        (unless (zero? ret)
+          (throw 'system-error "umount" "~S: ~A"
+                 (list target (strerror err))
+                 (list err)))
+        (when update-mtab?
+          (remove-from-mtab target))))))
+
+(define (kernel? pid)
+  "Return #t if PID designates a \"kernel thread\" rather than a normal
+user-land process."
+  (let ((stat (call-with-input-file (format #f "/proc/~a/stat" pid)
+                (compose string-tokenize read-string))))
+    ;; See proc.txt in Linux's documentation for the list of fields.
+    (match stat
+      ((pid tcomm state ppid pgrp sid tty_nr tty_pgrp flags min_flt
+            cmin_flt maj_flt cmaj_flt utime stime cutime cstime
+            priority nice num_thread it_real_value start_time
+            vsize rss rsslim
+            (= string->number start_code) (= string->number end_code) _ ...)
+       ;; Got this obscure trick from sysvinit's 'killall5' program.
+       (and (zero? start_code) (zero? end_code))))))
+
+(define (processes)
+  "Return the list of live processes."
+  (sort (filter-map (lambda (file)
+                      (let ((pid (string->number file)))
+                        (and pid
+                             (not (kernel? pid))
+                             pid)))
+                    (scandir "/proc"))
+        <))
+
+;;; syscalls.scm ends here
diff --git a/guix/build/vm.scm b/guix/build/vm.scm
index 33c898d968..e559542f0a 100644
--- a/guix/build/vm.scm
+++ b/guix/build/vm.scm
@@ -19,11 +19,15 @@
 (define-module (guix build vm)
   #:use-module (guix build utils)
   #:use-module (guix build linux-initrd)
+  #:use-module (guix build install)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:export (load-in-linux-vm
+            format-partition
+            initialize-root-partition
+            initialize-partition-table
             initialize-hard-disk))
 
 ;;; Commentary:
@@ -46,6 +50,7 @@
                            (qemu (qemu-command)) (memory-size 512)
                            linux initrd
                            make-disk-image? (disk-image-size 100)
+                           (disk-image-format "qcow2")
                            (references-graphs '()))
   "Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy
 the result to OUTPUT.
@@ -56,9 +61,12 @@ it via /dev/hda.
 
 REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
 the #:references-graphs parameter of 'derivation'."
+  (define image-file
+    (string-append "image." disk-image-format))
 
   (when make-disk-image?
-    (unless (zero? (system* "qemu-img" "create" "-f" "qcow2" "image.qcow2"
+    (unless (zero? (system* "qemu-img" "create" "-f" disk-image-format
+                            image-file
                             (number->string disk-image-size)))
       (error "qemu-img failed")))
 
@@ -88,13 +96,13 @@ the #:references-graphs parameter of 'derivation'."
                   "-append" (string-append "console=ttyS0 --load="
                                            builder)
                   (if make-disk-image?
-                      '("-hda" "image.qcow2")
+                      `("-drive" ,(string-append "file=" image-file
+                                                 ",if=virtio"))
                       '())))
     (error "qemu failed" qemu))
 
   (if make-disk-image?
-      (copy-file "image.qcow2"            ; XXX: who mkdir'd OUTPUT?
-                 output)
+      (copy-file image-file output)
       (begin
         (mkdir output)
         (copy-recursively "xchg" output))))
@@ -113,25 +121,20 @@ The data at PORT is the format produced by #:references-graphs."
            (loop (read-line port)
                  result)))))
 
-(define* (initialize-partition-table device
+(define* (initialize-partition-table device partition-size
                                      #:key
                                      (label-type "msdos")
-                                     partition-size)
+                                     (offset (expt 2 20)))
   "Create on DEVICE a partition table of type LABEL-TYPE, with a single
-partition of PARTITION-SIZE MiB.  Return #t on success."
-  (display "creating partition table...\n")
-  (zero? (system* "parted" "/dev/sda" "mklabel" label-type
-                  "mkpart" "primary" "ext2" "1MiB"
-                  (format #f "~aB" partition-size))))
-
-(define* (install-grub grub.cfg device mount-point)
-  "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on
-MOUNT-POINT.  Return #t on success."
-  (mkdir-p (string-append mount-point "/boot/grub"))
-  (symlink grub.cfg (string-append mount-point "/boot/grub/grub.cfg"))
-  (zero? (system* "grub-install" "--no-floppy"
-                  "--boot-directory" (string-append mount-point "/boot")
-                  device)))
+partition of PARTITION-SIZE bytes starting at OFFSET bytes.  Return #t on
+success."
+  (format #t "creating partition table with a ~a B partition...\n"
+          partition-size)
+  (unless (zero? (system* "parted" device "mklabel" label-type
+                          "mkpart" "primary" "ext2"
+                          (format #f "~aB" offset)
+                          (format #f "~aB" partition-size)))
+    (error "failed to create partition table")))
 
 (define* (populate-store reference-graphs target)
   "Populate the store under directory TARGET with the items specified in
@@ -153,80 +156,88 @@ REFERENCE-GRAPHS, a list of reference-graph files."
                                 (string-append target thing)))
             (things-to-copy)))
 
-(define (evaluate-populate-directive directive target)
-  "Evaluate DIRECTIVE, an sexp describing a file or directory to create under
-directory TARGET."
-  (match directive
-    (('directory name)
-     (mkdir-p (string-append target name)))
-    (('directory name uid gid)
-     (let ((dir (string-append target name)))
-       (mkdir-p dir)
-       (chown dir uid gid)))
-    ((new '-> old)
-     (symlink old (string-append target new)))))
-
-(define (reset-timestamps directory)
-  "Reset the timestamps of all the files under DIRECTORY, so that they appear
-as created and modified at the Epoch."
-  (display "clearing file timestamps...\n")
-  (for-each (lambda (file)
-              (let ((s (lstat file)))
-                ;; XXX: Guile uses libc's 'utime' function (not 'futime'), so
-                ;; the timestamp of symlinks cannot be changed, and there are
-                ;; symlinks here pointing to /gnu/store, which is the host,
-                ;; read-only store.
-                (unless (eq? (stat:type s) 'symlink)
-                  (utime file 0 0 0 0))))
-            (find-files directory "")))
-
-(define* (initialize-hard-disk #:key
-                               grub.cfg
-                               disk-image-size
-                               (mkfs "mkfs.ext3")
-                               initialize-store?
-                               (closures-to-copy '())
-                               (directives '()))
-  (unless (initialize-partition-table "/dev/sda"
-                                      #:partition-size
-                                      (- disk-image-size (* 5 (expt 2 20))))
-    (error "failed to create partition table"))
-
-  (display "creating ext3 partition...\n")
-  (unless (zero? (system* mkfs "-F" "/dev/sda1"))
-    (error "failed to create partition"))
+(define MS_BIND 4096)                             ; <sys/mounts.h> again!
 
-  (display "mounting partition...\n")
-  (mkdir "/fs")
-  (mount "/dev/sda1" "/fs" "ext3")
+(define (format-partition partition type)
+  "Create a file system TYPE on PARTITION."
+  (format #t "creating ~a partition...\n" type)
+  (unless (zero? (system* (string-append "mkfs." type) "-F" partition))
+    (error "failed to create partition")))
 
-  (when (pair? closures-to-copy)
+(define* (initialize-root-partition target-directory
+                                    #:key copy-closures? register-closures?
+                                    closures)
+  "Initialize the root partition mounted at TARGET-DIRECTORY."
+  (define target-store
+    (string-append target-directory (%store-directory)))
+
+  (when copy-closures?
     ;; Populate the store.
-    (populate-store (map (cut string-append "/xchg/" <>)
-                         closures-to-copy)
-                    "/fs"))
+    (populate-store (map (cut string-append "/xchg/" <>) closures)
+                    target-directory))
 
   ;; Populate /dev.
-  (make-essential-device-nodes #:root "/fs")
+  (make-essential-device-nodes #:root target-directory)
 
   ;; Optionally, register the inputs in the image's store.
-  (when initialize-store?
+  (when register-closures?
+    (unless copy-closures?
+      ;; XXX: 'guix-register' wants to palpate the things it registers, so
+      ;; bind-mount the store on the target.
+      (mkdir-p target-store)
+      (mount (%store-directory) target-store "" MS_BIND))
+
+    (display "registering closures...\n")
     (for-each (lambda (closure)
-                (let ((status (system* "guix-register" "--prefix" "/fs"
-                                       (string-append "/xchg/" closure))))
-                  (unless (zero? status)
-                    (error "failed to register store items" closure))))
-              closures-to-copy))
+                (register-closure target-directory
+                                  (string-append "/xchg/" closure)))
+              closures)
+    (unless copy-closures?
+      (system* "umount" target-store)))
+
+  ;; Add the non-store directories and files.
+  (display "populating...\n")
+  (populate-root-file-system target-directory))
+
+(define* (initialize-hard-disk device
+                               #:key
+                               grub.cfg
+                               disk-image-size
+                               (file-system-type "ext4")
+                               (closures '())
+                               copy-closures?
+                               (register-closures? #t))
+  "Initialize DEVICE, a disk of DISK-IMAGE-SIZE bytes, with a
+FILE-SYSTEM-TYPE partition, and with GRUB installed.  If REGISTER-CLOSURES? is
+true, register all of CLOSURES is the partition's store.  If COPY-CLOSURES? is
+true, copy all of CLOSURES to the partition."
+  (define target-directory
+    "/fs")
+
+  (define partition
+    (string-append device "1"))
+
+  (initialize-partition-table device
+                              (- disk-image-size (* 5 (expt 2 20))))
+
+  (format-partition partition file-system-type)
+
+  (display "mounting partition...\n")
+  (mkdir target-directory)
+  (mount partition target-directory file-system-type)
 
-  ;; Evaluate the POPULATE directives.
-  (for-each (cut evaluate-populate-directive <> "/fs")
-            directives)
+  (initialize-root-partition target-directory
+                             #:copy-closures? copy-closures?
+                             #:register-closures? register-closures?
+                             #:closures closures)
 
-  (unless (install-grub grub.cfg "/dev/sda" "/fs")
-    (error "failed to install GRUB"))
+  (install-grub grub.cfg device target-directory)
 
-  (reset-timestamps "/fs")
+  ;; 'guix-register' resets timestamps and everything, so no need to do it
+  ;; once more in that case.
+  (unless register-closures?
+    (reset-timestamps target-directory))
 
-  (zero? (system* "umount" "/fs")))
+  (zero? (system* "umount" target-directory)))
 
 ;;; vm.scm ends here
diff --git a/guix/derivations.scm b/guix/derivations.scm
index a3a4eae6ac..09b7ec079e 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -435,6 +435,14 @@ that form."
                  port)
      (display ")" port))))
 
+(define derivation->string
+  (memoize
+   (lambda (drv)
+     "Return the external representation of DRV as a string."
+     (with-fluids ((%default-port-encoding "UTF-8"))
+       (call-with-output-string
+        (cut write-derivation drv <>))))))
+
 (define* (derivation->output-path drv #:optional (output "out"))
   "Return the store path of its output OUTPUT."
   (let ((outputs (derivation-outputs drv)))
@@ -517,9 +525,7 @@ in SIZE bytes."
          ;; the SHA256 port's `write' method gets called for every single
          ;; character.
          (sha256
-          (with-fluids ((%default-port-encoding "UTF-8"))
-            (string->utf8 (call-with-output-string
-                           (cut write-derivation drv <>)))))))))))
+          (string->utf8 (derivation->string drv)))))))))
 
 (define (store-path type hash name)               ; makeStorePath
   "Return the store path for NAME/HASH/TYPE."
@@ -685,8 +691,7 @@ derivations where the costs of data transfers would outweigh the benefits."
          (drv        (add-output-paths drv-masked)))
 
     (let ((file (add-text-to-store store (string-append name ".drv")
-                                   (call-with-output-string
-                                    (cut write-derivation drv <>))
+                                   (derivation->string drv)
                                    (map derivation-input-path
                                         inputs))))
       (set-file-name drv file))))
diff --git a/guix/download.scm b/guix/download.scm
index 2cb0740897..47b72f432a 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
+;;; Copyright © 2013, 2014 Andreas Enge <andreas@enge.fr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -23,6 +23,8 @@
   #:use-module (guix packages)
   #:use-module ((guix store) #:select (derivation-path? add-to-store))
   #:use-module ((guix build download) #:renamer (symbol-prefix-proc 'build:))
+  #:use-module (guix monads)
+  #:use-module (guix gexp)
   #:use-module (guix utils)
   #:use-module (web uri)
   #:use-module (srfi srfi-1)
@@ -155,23 +157,39 @@
        "ftp://ftp.nara.wide.ad.jp/pub/CPAN/"
        "http://mirrors.163.com/cpan/"
        "ftp://cpan.mirror.ac.za/")
-      (imagemagick       ; from http://www.imagemagick.org/script/download.php
+      (imagemagick
+       ;; from http://www.imagemagick.org/script/download.php
+       ;; (without mirrors that are unavailable or not up to date)
+       ;; mirrors keeping old versions at the top level
+       "ftp://ftp.sunet.se/pub/multimedia/graphics/ImageMagick/"
+       "ftp://sunsite.icm.edu.pl/packages/ImageMagick/"
+       ;; mirrors moving old versions to "legacy"
+       "http://mirrors-au.go-parts.com/mirrors/ImageMagick/"
+       "ftp://mirror.aarnet.edu.au/pub/imagemagick/"
        "http://mirror.checkdomain.de/imagemagick/"
-       "ftp://gd.tuwien.ac.at/pub/graphics/ImageMagick/"
-       "http://www.imagemagick.org/download"
-       "ftp://mirror.searchdaimon.com/ImageMagick"
+       "ftp://ftp.kddlabs.co.jp/graphics/ImageMagick/"
+       "ftp://ftp.u-aizu.ac.jp/pub/graphics/image/ImageMagick/imagemagick.org/"
+       "ftp://ftp.nluug.nl/pub/ImageMagick/"
+       "http://ftp.surfnet.nl/pub/ImageMagick/"
+       "http://mirror.searchdaimon.com/ImageMagick"
+       "ftp://ftp.tpnet.pl/pub/graphics/ImageMagick/"
+       "http://mirrors-ru.go-parts.com/mirrors/ImageMagick/"
        "http://mirror.is.co.za/pub/imagemagick/"
-       "ftp://mirror.aarnet.edu.au/pub/imagemagick/")
+       "http://mirrors-uk.go-parts.com/mirrors/ImageMagick/"
+       "http://mirrors-usa.go-parts.com/mirrors/ImageMagick/"
+       "ftp://ftp.fifi.org/pub/ImageMagick/"
+       "http://www.imagemagick.org/download/"
+       ;; one legacy location as a last resort
+       "http://www.imagemagick.org/download/legacy/")
       (debian
        "http://ftp.de.debian.org/debian/"
        "http://ftp.fr.debian.org/debian/"
        "http://ftp.debian.org/debian/"))))
 
-(define (gnutls-derivation store system)
-  "Return the GnuTLS derivation for SYSTEM."
-  (let* ((module (resolve-interface '(gnu packages gnutls)))
-         (gnutls (module-ref module 'gnutls)))
-    (package-derivation store gnutls system)))
+(define (gnutls-package)
+  "Return the GnuTLS package for SYSTEM."
+  (let ((module (resolve-interface '(gnu packages gnutls))))
+    (module-ref module 'gnutls)))
 
 (define* (url-fetch store url hash-algo hash
                     #:optional name
@@ -186,22 +204,13 @@ different file name.
 When one of the URL starts with mirror://, then its host part is
 interpreted as the name of a mirror scheme, taken from MIRRORS; MIRRORS
 must be a list of symbol/URL-list pairs."
-  (define builder
-    `(begin
-       (use-modules (guix build download))
-       (url-fetch ',url %output
-                  #:mirrors ',mirrors)))
-
   (define guile-for-build
-    (match guile
-      ((? package?)
-       (package-derivation store guile system))
-      ((and (? string?) (? derivation-path?))
-       guile)
-      (#f                                         ; the default
-       (let* ((distro (resolve-interface '(gnu packages base)))
-              (guile  (module-ref distro 'guile-final)))
-         (package-derivation store guile system)))))
+    (package-derivation store
+                        (or guile
+                            (let ((distro
+                                   (resolve-interface '(gnu packages base))))
+                              (module-ref distro 'guile-final)))
+                        system))
 
   (define file-name
     (match url
@@ -219,34 +228,36 @@ must be a list of symbol/URL-list pairs."
         ((url ...)
          (any https? url)))))
 
-  (let* ((gnutls-drv (if need-gnutls?
-                         (gnutls-derivation store system)
-                         (values #f #f)))
-         (gnutls     (and gnutls-drv
-                          (derivation->output-path gnutls-drv "out")))
-         (env-vars   (if gnutls
-                         (let ((dir (string-append gnutls "/share/guile/site")))
-                           ;; XXX: `GUILE_LOAD_COMPILED_PATH' is overridden
-                           ;; by `build-expression->derivation', so we can't
-                           ;; set it here.
-                           `(("GUILE_LOAD_PATH" . ,dir)))
-                         '())))
-    (build-expression->derivation store (or name file-name) builder
-                                  #:system system
-                                  #:inputs (if gnutls-drv
-                                               `(("gnutls" ,gnutls-drv))
-                                               '())
-                                  #:hash-algo hash-algo
-                                  #:hash hash
-                                  #:modules '((guix build download)
-                                              (guix build utils)
-                                              (guix ftp-client))
-                                  #:guile-for-build guile-for-build
-                                  #:env-vars env-vars
+  (define builder
+    #~(begin
+        #$(if need-gnutls?
+
+              ;; Add GnuTLS to the inputs and to the load path.
+              #~(eval-when (load expand eval)
+                  (set! %load-path
+                        (cons (string-append #$(gnutls-package)
+                                             "/share/guile/site")
+                              %load-path)))
+              #~#t)
+
+        (use-modules (guix build download))
+        (url-fetch '#$url #$output
+                   #:mirrors '#$mirrors)))
+
+  (run-with-store store
+    (gexp->derivation (or name file-name) builder
+                      #:system system
+                      #:hash-algo hash-algo
+                      #:hash hash
+                      #:modules '((guix build download)
+                                  (guix build utils)
+                                  (guix ftp-client))
+                      #:guile-for-build guile-for-build
 
-                                  ;; In general, offloading downloads is not a
-                                  ;; good idea.
-                                  #:local-build? #t)))
+                      ;; In general, offloading downloads is not a good idea.
+                      #:local-build? #t)
+    #:guile-for-build guile-for-build
+    #:system system))
 
 (define* (download-to-store store url #:optional (name (basename url))
                             #:key (log (current-error-port)))
diff --git a/guix/ftp-client.scm b/guix/ftp-client.scm
index dd9135e95a..761980ac8f 100644
--- a/guix/ftp-client.scm
+++ b/guix/ftp-client.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010, 2011, 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2010, 2011, 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -73,7 +73,8 @@
         (throw 'ftp-error port command code message))))
 
 (define (%ftp-login user pass port)
-  (let ((command (string-append "USER " user (string #\newline))))
+  (let ((command (string-append "USER " user
+                                (string #\return) (string #\newline))))
     (display command port)
     (let-values (((code message) (%ftp-listen port)))
       (case code
diff --git a/guix/gexp.scm b/guix/gexp.scm
new file mode 100644
index 0000000000..a2ba50d957
--- /dev/null
+++ b/guix/gexp.scm
@@ -0,0 +1,415 @@
+;;; 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 gexp)
+  #:use-module ((guix store)
+                #:select (direct-store-path?))
+  #:use-module (guix monads)
+  #:use-module ((guix derivations)
+                #:select (derivation? derivation->output-path
+                          %guile-for-build derivation))
+  #:use-module (guix packages)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 match)
+  #:export (gexp
+            gexp?
+            gexp->derivation
+            gexp->file
+            gexp->script))
+
+;;; Commentary:
+;;;
+;;; This module implements "G-expressions", or "gexps".  Gexps are like
+;;; S-expressions (sexps), with two differences:
+;;;
+;;;   1. References (un-quotations) to derivations or packages in a gexp are
+;;;      replaced by the corresponding output file name;
+;;;
+;;;   2. Gexps embed information about the derivations they refer to.
+;;;
+;;; Gexps make it easy to write to files Scheme code that refers to store
+;;; items, or to write Scheme code to build derivations.
+;;;
+;;; Code:
+
+;; "G expressions".
+(define-record-type <gexp>
+  (make-gexp references proc)
+  gexp?
+  (references gexp-references)                    ; ((DRV-OR-PKG OUTPUT) ...)
+  (proc       gexp-proc))                         ; procedure
+
+(define (write-gexp gexp port)
+  "Write GEXP on PORT."
+  (display "#<gexp " port)
+  (write (apply (gexp-proc gexp) (gexp-references gexp)) port)
+  (format port " ~a>"
+          (number->string (object-address gexp) 16)))
+
+(set-record-type-printer! <gexp> write-gexp)
+
+;; Reference to one of the derivation's outputs, for gexps used in
+;; derivations.
+(define-record-type <output-ref>
+  (output-ref name)
+  output-ref?
+  (name output-ref-name))
+
+(define raw-derivation
+  (store-lift derivation))
+
+(define (lower-inputs inputs)
+  "Turn any package from INPUTS into a derivation; return the corresponding
+input list as a monadic value."
+  (with-monad %store-monad
+    (sequence %store-monad
+              (map (match-lambda
+                    (((? package? package) sub-drv ...)
+                     (mlet %store-monad ((drv (package->derivation package)))
+                       (return `(,drv ,@sub-drv))))
+                    (((? origin? origin) sub-drv ...)
+                     (mlet %store-monad ((drv (origin->derivation origin)))
+                       (return `(,drv ,@sub-drv))))
+                    (input
+                     (return input)))
+                   inputs))))
+
+(define* (gexp->derivation name exp
+                           #:key
+                           (system (%current-system))
+                           hash hash-algo recursive?
+                           (env-vars '())
+                           (modules '())
+                           (guile-for-build (%guile-for-build))
+                           references-graphs
+                           local-build?)
+  "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a
+derivation) on SYSTEM.
+
+Make MODULES available in the evaluation context of EXP; MODULES is a list of
+names of Guile modules from the current search path to be copied in the store,
+compiled, and made available in the load path during the execution of
+EXP---e.g., '((guix build utils) (guix build gnu-build-system)).
+
+The other arguments are as for 'derivation'."
+  (define %modules modules)
+  (define outputs (gexp-outputs exp))
+
+  (mlet* %store-monad ((inputs   (lower-inputs (gexp-inputs exp)))
+                       (sexp     (gexp->sexp exp))
+                       (builder  (text-file (string-append name "-builder")
+                                            (object->string sexp)))
+                       (modules  (if (pair? %modules)
+                                     (imported-modules %modules
+                                                       #:system system
+                                                       #:guile guile-for-build)
+                                     (return #f)))
+                       (compiled (if (pair? %modules)
+                                     (compiled-modules %modules
+                                                       #:system system
+                                                       #:guile guile-for-build)
+                                     (return #f)))
+                       (guile    (if guile-for-build
+                                     (return guile-for-build)
+                                     (package->derivation (default-guile)
+                                                          system))))
+    (raw-derivation name
+                    (string-append (derivation->output-path guile)
+                                   "/bin/guile")
+                    `("--no-auto-compile"
+                      ,@(if (pair? %modules)
+                            `("-L" ,(derivation->output-path modules)
+                              "-C" ,(derivation->output-path compiled))
+                            '())
+                      ,builder)
+                    #:outputs outputs
+                    #:env-vars env-vars
+                    #:system system
+                    #:inputs `((,guile)
+                               (,builder)
+                               ,@(if modules
+                                     `((,modules) (,compiled) ,@inputs)
+                                     inputs))
+                    #:hash hash #:hash-algo hash-algo #:recursive? recursive?
+                    #:references-graphs references-graphs
+                    #:local-build? local-build?)))
+
+(define (gexp-inputs exp)
+  "Return the input list for EXP."
+  (define (add-reference-inputs ref result)
+    (match ref
+      (((? derivation?) (? string?))
+       (cons ref result))
+      (((? package?) (? string?))
+       (cons ref result))
+      (((? origin?) (? string?))
+       (cons ref result))
+      ((? gexp? exp)
+       (append (gexp-inputs exp) result))
+      (((? string? file))
+       (if (direct-store-path? file)
+           (cons ref result)
+           result))
+      ((refs ...)
+       (fold-right add-reference-inputs result refs))
+      (_
+       ;; Ignore references to other kinds of objects.
+       result)))
+
+  (fold-right add-reference-inputs
+              '()
+              (gexp-references exp)))
+
+(define (gexp-outputs exp)
+  "Return the outputs referred to by EXP as a list of strings."
+  (define (add-reference-output ref result)
+    (match ref
+      (($ <output-ref> name)
+       (cons name result))
+      ((? gexp? exp)
+       (append (gexp-outputs exp) result))
+      (_
+       result)))
+
+  (fold-right add-reference-output
+              '()
+              (gexp-references exp)))
+
+(define* (gexp->sexp exp)
+  "Return (monadically) the sexp corresponding to EXP for the given OUTPUT,
+and in the current monad setting (system type, etc.)"
+  (define (reference->sexp ref)
+    (with-monad %store-monad
+      (match ref
+        (((? derivation? drv) (? string? output))
+         (return (derivation->output-path drv output)))
+        (((? package? p) (? string? output))
+         (package-file p #:output output))
+        (((? origin? o) (? string? output))
+         (mlet %store-monad ((drv (origin->derivation o)))
+           (return (derivation->output-path drv output))))
+        (($ <output-ref> output)
+         ;; Output file names are not known in advance but the daemon defines
+         ;; an environment variable for each of them at build time, so use
+         ;; that trick.
+         (return `((@ (guile) getenv) ,output)))
+        ((? gexp? exp)
+         (gexp->sexp exp))
+        (((? string? str))
+         (return (if (direct-store-path? str) str ref)))
+        ((refs ...)
+         (sequence %store-monad (map reference->sexp refs)))
+        (x
+         (return x)))))
+
+  (mlet %store-monad
+      ((args (sequence %store-monad
+                       (map reference->sexp (gexp-references exp)))))
+    (return (apply (gexp-proc exp) args))))
+
+(define (canonicalize-reference ref)
+  "Return a canonical variant of REF, which adds any missing output part in
+package/derivation references."
+  (match ref
+    ((? package? p)
+     `(,p "out"))
+    ((? origin? o)
+     `(,o "out"))
+    ((? derivation? d)
+     `(,d "out"))
+    (((? package?) (? string?))
+     ref)
+    (((? origin?) (? string?))
+     ref)
+    (((? derivation?) (? string?))
+     ref)
+    ((? string? s)
+     (if (direct-store-path? s) `(,s) s))
+    ((refs ...)
+     (map canonicalize-reference refs))
+    (x x)))
+
+(define (syntax-location-string s)
+  "Return a string representing the source code location of S."
+  (let ((props (syntax-source s)))
+    (if props
+        (let ((file   (assoc-ref props 'filename))
+              (line   (and=> (assoc-ref props 'line) 1+))
+              (column (assoc-ref props 'column)))
+          (if file
+              (simple-format #f "~a:~a:~a"
+                             file line column)
+              (simple-format #f "~a:~a" line column)))
+        "<unknown location>")))
+
+(define-syntax gexp
+  (lambda (s)
+    (define (collect-escapes exp)
+      ;; Return all the 'ungexp' present in EXP.
+      (let loop ((exp    exp)
+                 (result '()))
+        (syntax-case exp (ungexp ungexp-splicing)
+          ((ungexp _)
+           (cons exp result))
+          ((ungexp _ _)
+           (cons exp result))
+          ((ungexp-splicing _ ...)
+           (cons exp result))
+          ((exp0 exp ...)
+           (let ((result (loop #'exp0 result)))
+             (fold loop result #'(exp ...))))
+          (_
+           result))))
+
+    (define (escape->ref exp)
+      ;; Turn 'ungexp' form EXP into a "reference".
+      (syntax-case exp (ungexp ungexp-splicing output)
+        ((ungexp output)
+         #'(output-ref "out"))
+        ((ungexp output name)
+         #'(output-ref name))
+        ((ungexp thing)
+         #'thing)
+        ((ungexp drv-or-pkg out)
+         #'(list drv-or-pkg out))
+        ((ungexp-splicing lst)
+         #'lst)))
+
+    (define (substitute-references exp substs)
+      ;; Return a variant of EXP where all the cars of SUBSTS have been
+      ;; replaced by the corresponding cdr.
+      (syntax-case exp (ungexp ungexp-splicing)
+        ((ungexp _ ...)
+         (match (assoc exp substs)
+           ((_ id)
+            id)
+           (_
+            #'(syntax-error "error: no 'ungexp' substitution"
+                            #'ref))))
+        (((ungexp-splicing _ ...) rest ...)
+         (syntax-case exp ()
+           ((exp rest ...)
+            (match (assoc #'exp substs)
+              ((_ id)
+               (with-syntax ((id id))
+                 #`(append id
+                           #,(substitute-references #'(rest ...) substs))))
+              (_
+               #'(syntax-error "error: no 'ungexp-splicing' substitution"
+                               #'ref))))))
+        ((exp0 exp ...)
+         #`(cons #,(substitute-references #'exp0 substs)
+                 #,(substitute-references #'(exp ...) substs)))
+        (x #''x)))
+
+    (syntax-case s (ungexp output)
+      ((_ exp)
+       (let* ((escapes (delete-duplicates (collect-escapes #'exp)))
+              (formals (generate-temporaries escapes))
+              (sexp    (substitute-references #'exp (zip escapes formals)))
+              (refs    (map escape->ref escapes)))
+         #`(make-gexp (map canonicalize-reference (list #,@refs))
+                      (lambda #,formals
+                        #,sexp)))))))
+
+
+;;;
+;;; Convenience procedures.
+;;;
+
+(define (default-guile)
+  ;; Lazily resolve 'guile-final'.  This module must not refer to (gnu …)
+  ;; modules directly, to avoid circular dependencies, hence this hack.
+  (module-ref (resolve-interface '(gnu packages base))
+              'guile-final))
+
+(define* (gexp->script name exp
+                       #:key (modules '()) (guile (default-guile)))
+  "Return an executable script NAME that runs EXP using GUILE with MODULES in
+its search path."
+  (mlet %store-monad ((modules  (imported-modules modules))
+                      (compiled (compiled-modules modules)))
+    (gexp->derivation name
+                      (gexp
+                       (call-with-output-file (ungexp output)
+                         (lambda (port)
+                           (format port
+                                   "#!~a/bin/guile --no-auto-compile~%!#~%"
+                                   (ungexp guile))
+                           (write
+                            '(set! %load-path
+                                   (cons (ungexp modules) %load-path))
+                            port)
+                           (write
+                            '(set! %load-compiled-path
+                                   (cons (ungexp compiled)
+                                         %load-compiled-path))
+                            port)
+                           (write '(ungexp exp) port)
+                           (chmod port #o555)))))))
+
+(define (gexp->file name exp)
+  "Return a derivation that builds a file NAME containing EXP."
+  (gexp->derivation name
+                    (gexp
+                     (call-with-output-file (ungexp output)
+                       (lambda (port)
+                         (write '(ungexp exp) port))))))
+
+
+
+;;;
+;;; Syntactic sugar.
+;;;
+
+(eval-when (expand load eval)
+  (define (read-ungexp chr port)
+    "Read an 'ungexp' or 'ungexp-splicing' form from PORT."
+    (define unquote-symbol
+      (match (peek-char port)
+        (#\@
+         (read-char port)
+         'ungexp-splicing)
+        (_
+         'ungexp)))
+
+    (match (read port)
+      ((? symbol? symbol)
+       (let ((str (symbol->string symbol)))
+         (match (string-index-right str #\:)
+           (#f
+            `(,unquote-symbol ,symbol))
+           (colon
+            (let ((name   (string->symbol (substring str 0 colon)))
+                  (output (substring str (+ colon 1))))
+              `(,unquote-symbol ,name ,output))))))
+      (x
+       `(,unquote-symbol ,x))))
+
+  (define (read-gexp chr port)
+    "Read a 'gexp' form from PORT."
+    `(gexp ,(read port)))
+
+  ;; Extend the reader
+  (read-hash-extend #\~ read-gexp)
+  (read-hash-extend #\$ read-ungexp))
+
+;;; gexp.scm ends here
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 14195da7ba..7b608daea2 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -167,13 +167,22 @@
      (lambda (package)
        "Return true if PACKAGE is a GNU package.  This procedure may access the
 network to check in GNU's database."
-       ;; TODO: Find a way to determine that a package is non-GNU without going
-       ;; through the network.
+       (define (mirror-type url)
+         (let ((uri (string->uri url)))
+           (and (eq? (uri-scheme uri) 'mirror)
+                (if (member (uri-host uri) '("gnu" "gnupg" "gcc"))
+                    'gnu
+                    'non-gnu))))
+
        (let ((url  (and=> (package-source package) origin-uri))
              (name (package-name package)))
-         (or (and (string? url) (string-prefix? "mirror://gnu" url))
-             (and (member name (map gnu-package-name (official-gnu-packages)))
-                  #t)))))))
+         (case (and (string? url) (mirror-type url))
+           ((gnu) #t)
+           ((non-gnu) #f)
+           (else
+            ;; Last resort: resort to the network.
+            (and (member name (map gnu-package-name (official-gnu-packages)))
+                 #t))))))))
 
 
 ;;;
diff --git a/guix/http-client.scm b/guix/http-client.scm
index 1f05df4b05..4770628e45 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -162,7 +162,19 @@ closed it will also close PORT, unless the KEEP-ALIVE? is true."
 (define* (open-socket-for-uri uri #:key (buffered? #t))
   "Return an open port for URI.  When BUFFERED? is false, the returned port is
 unbuffered."
+  (define rmem-max
+    ;; The maximum size for a receive buffer on Linux, see socket(7).
+    "/proc/sys/net/core/rmem_max")
+
+  (define buffer-size
+    (if (file-exists? rmem-max)
+        (call-with-input-file rmem-max read)
+        126976))                   ; the default for Linux, per 'rmem_default'
+
   (let ((s ((@ (web client) open-socket-for-uri) uri)))
+    ;; Work around <http://bugs.gnu.org/15368> by restoring a decent
+    ;; buffer size.
+    (setsockopt s SOL_SOCKET SO_RCVBUF buffer-size)
     (unless buffered?
       (setvbuf s _IONBF))
     s))
diff --git a/guix/licenses.scm b/guix/licenses.scm
index fce3d2b896..c3464b5f5f 100644
--- a/guix/licenses.scm
+++ b/guix/licenses.scm
@@ -26,6 +26,7 @@
             boost1.0
             bsd-2 bsd-3 bsd-4 bsd-style
             cddl1.0
+            cecill-c
             cpl1.0
             epl1.0
             expat
@@ -112,6 +113,11 @@ which may be a file:// URI pointing the package's tree."
            "http://directory.fsf.org/wiki/License:CDDLv1.0"
            "https://www.gnu.org/licenses/license-list#CDDL"))
 
+(define cecill-c
+  (license "CeCILL-C"
+           "http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html"
+           "https://www.gnu.org/licenses/license-list.html#CeCILL"))
+
 (define cpl1.0
   (license "CPL 1.0"
            "http://directory.fsf.org/wiki/License:CPLv1.0"
diff --git a/guix/monads.scm b/guix/monads.scm
index db8b645402..ec2b7f8b3b 100644
--- a/guix/monads.scm
+++ b/guix/monads.scm
@@ -56,10 +56,9 @@
             text-file
             text-file*
             package-file
+            origin->derivation
             package->derivation
-            built-derivations
-            derivation-expression
-            lower-inputs)
+            built-derivations)
   #:replace (imported-modules
              compiled-modules))
 
@@ -356,6 +355,7 @@ and store file names; the resulting store file holds references to all these."
        (lambda (port)
          (display ,(computed-text text inputs) port))))
 
+  ;; TODO: Rewrite using 'gexp->derivation'.
   (mlet %store-monad ((inputs (lower-inputs inputs)))
     (derivation-expression name (builder inputs)
                            #:inputs inputs)))
@@ -376,7 +376,7 @@ OUTPUT directory of PACKAGE."
 (define (lower-inputs inputs)
   "Turn any package from INPUTS into a derivation; return the corresponding
 input list as a monadic value."
-  ;; XXX: Should probably be in (guix packages).
+  ;; XXX: This procedure is bound to disappear with 'derivation-expression'.
   (with-monad %store-monad
     (sequence %store-monad
               (map (match-lambda
@@ -390,11 +390,15 @@ input list as a monadic value."
                    inputs))))
 
 (define derivation-expression
+  ;; XXX: This procedure is superseded by 'gexp->derivation'.
   (store-lift build-expression->derivation))
 
 (define package->derivation
   (store-lift package-derivation))
 
+(define origin->derivation
+  (store-lift package-source-derivation))
+
 (define imported-modules
   (store-lift (@ (guix derivations) imported-modules)))
 
@@ -410,10 +414,15 @@ input list as a monadic value."
                          (system (%current-system)))
   "Run MVAL, a monadic value in the store monad, in STORE, an open store
 connection."
+  (define (default-guile)
+    ;; Lazily resolve 'guile-final'.  This module must not refer to (gnu …)
+    ;; modules directly, to avoid circular dependencies, hence this hack.
+    (module-ref (resolve-interface '(gnu packages base))
+                'guile-final))
+
   (parameterize ((%guile-for-build (or guile-for-build
                                        (package-derivation store
-                                                           (@ (gnu packages base)
-                                                              guile-final)
+                                                           (default-guile)
                                                            system)))
                  (%current-system system))
     (mval store)))
diff --git a/guix/nar.scm b/guix/nar.scm
index 0bf8ac317d..0a7187c2dd 100644
--- a/guix/nar.scm
+++ b/guix/nar.scm
@@ -334,36 +334,29 @@ held."
         (unlock-store-file target)))))
 
 (define (temporary-store-file)
-  "Return the file name of a temporary file created in the store that is
-protected from garbage collection."
+  "Return the file name of a temporary file created in the store."
   (let* ((template (string-append (%store-prefix) "/guix-XXXXXX"))
          (port     (mkstemp! template)))
     (close-port port)
-
-    ;; Make sure TEMPLATE is not collected while we populate it.
-    (add-permanent-root template)
-
-    ;; There's a small window during which the GC could delete the file.  Try
-    ;; again if that happens.
-    (if (file-exists? template)
-        (begin
-          ;; It's up to the caller to create that file or directory.
-          (delete-file template)
-          template)
-        (begin
-          (remove-permanent-root template)
-          (temporary-store-file)))))
+    template))
 
 (define-syntax-rule (with-temporary-store-file name body ...)
   "Evaluate BODY with NAME bound to the file name of a temporary store item
 protected from GC."
-  (let ((name (temporary-store-file)))
-    (dynamic-wind
-      (const #t)
-      (lambda ()
-        body ...)
-      (lambda ()
-        (remove-permanent-root name)))))
+  (let loop ((name (temporary-store-file)))
+    (with-store store
+      ;; Add NAME to the current process' roots.  (Opening this connection to
+      ;; the daemon allows us to reuse its code that deals with the
+      ;; per-process roots file.)
+      (add-temp-root store name)
+
+      ;; There's a window during which GC could delete NAME.  Try again when
+      ;; that happens.
+      (if (file-exists? name)
+          (begin
+            (delete-file name)
+            body ...)
+          (loop (temporary-store-file))))))
 
 (define* (restore-one-item port
                            #:key acl (verify-signature? #t) (lock? #t)
@@ -377,7 +370,7 @@ protected from GC."
     (let ((signature (catch 'gcry-error
                        (lambda ()
                          (string->canonical-sexp signature))
-                       (lambda (err . _)
+                       (lambda (key proc err)
                          (raise (condition
                                  (&message
                                   (message "signature is not a valid \
diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm
index 481d3f2463..71104128c1 100644
--- a/guix/pk-crypto.scm
+++ b/guix/pk-crypto.scm
@@ -134,11 +134,16 @@ thrown along with 'gcry-error'."
          (proc (pointer->procedure int ptr `(* * ,size_t ,int))))
     (lambda (str)
       "Parse STR and return the corresponding gcrypt s-expression."
+
+      ;; When STR comes from 'canonical-sexp->string', it may contain
+      ;; characters that are really meant to be interpreted as bytes as in a C
+      ;; 'char *'.  Thus, convert STR to ISO-8859-1 so the byte values of the
+      ;; characters are preserved.
       (let* ((sexp (bytevector->pointer (make-bytevector (sizeof '*))))
-             (err  (proc sexp (string->pointer str) 0 1)))
+             (err  (proc sexp (string->pointer str "ISO-8859-1") 0 1)))
         (if (= 0 err)
             (pointer->canonical-sexp (dereference-pointer sexp))
-            (throw 'gcry-error err))))))
+            (throw 'gcry-error 'string->canonical-sexp err))))))
 
 (define-syntax GCRYSEXP_FMT_ADVANCED
   (identifier-syntax 3))
@@ -291,7 +296,7 @@ is 'private-key'.)"
                         (canonical-sexp->pointer secret-key))))
         (if (= 0 err)
             (pointer->canonical-sexp (dereference-pointer sig))
-            (throw 'gry-error err))))))
+            (throw 'gcry-error 'sign err))))))
 
 (define verify
   (let* ((ptr  (libgcrypt-func "gcry_pk_verify"))
@@ -313,7 +318,7 @@ s-expression like: (genkey (rsa (nbits 4:2048)))."
              (err (proc key (canonical-sexp->pointer params))))
         (if (zero? err)
             (pointer->canonical-sexp (dereference-pointer key))
-            (throw 'gcry-error err))))))
+            (throw 'gcry-error 'generate-key err))))))
 
 (define find-sexp-token
   (let* ((ptr  (libgcrypt-func "gcry_sexp_find_token"))
@@ -398,4 +403,13 @@ use pattern matching."
 
        (write sexp)))))
 
+(define (gcrypt-error-printer port key args default-printer)
+  "Print the gcrypt error specified by ARGS."
+  (match args
+    ((proc err)
+     (format port "In procedure ~a: ~a: ~a"
+             proc (error-source err) (error-string err)))))
+
+(set-exception-printer! 'gcry-error gcrypt-error-printer)
+
 ;;; pk-crypto.scm ends here
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index 0a2e186da6..84904e29da 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -123,7 +123,7 @@ Export/import one or more packages from/to the store.\n"))
                               (string->canonical-sexp
                                (or arg %key-generation-parameters))))
                          (alist-cons 'generate-key params result)))
-                     (lambda (key err)
+                     (lambda (key proc err)
                        (leave (_ "invalid key generation parameters: ~a: ~a~%")
                               (error-source err)
                               (error-string err))))))
@@ -248,7 +248,7 @@ this may take time...~%"))
   (let* ((pair   (catch 'gcry-error
                    (lambda ()
                      (generate-key parameters))
-                   (lambda (key err)
+                   (lambda (key proc err)
                      (leave (_ "key generation failed: ~a: ~a~%")
                             (error-source err)
                             (error-string err)))))
@@ -275,7 +275,7 @@ the input port."
     (catch 'gcry-error
       (lambda ()
         (string->canonical-sexp (get-string-all (current-input-port))))
-      (lambda (key err)
+      (lambda (key proc err)
         (leave (_ "failed to read public key: ~a: ~a~%")
                (error-source err) (error-string err)))))
 
diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm
index 62717bb09c..e9900689fa 100644
--- a/guix/scripts/authenticate.scm
+++ b/guix/scripts/authenticate.scm
@@ -81,6 +81,13 @@ to stdout upon success."
                    (canonical-sexp->string subject)))
         (leave (_ "error: corrupt signature data: ~a~%")
                (canonical-sexp->string signature)))))
+
+(define %default-port-conversion-strategy
+  ;; This fluid is in Guile > 2.0.5.
+  (if (defined? '%default-port-conversion-strategy)
+      (@ (guile) %default-port-conversion-strategy)
+      (make-fluid #f)))
+
 
 ;;;
 ;;; Entry point with 'openssl'-compatible interface.  We support this
@@ -89,30 +96,39 @@ to stdout upon success."
 ;;;
 
 (define (guix-authenticate . args)
-  (match args
-    ;; As invoked by guix-daemon.
-    (("rsautl" "-sign" "-inkey" key "-in" hash-file)
-     (call-with-input-file hash-file
-       (lambda (port)
-         (sign-with-key key port))))
-    ;; As invoked by Nix/Crypto.pm (used by Hydra.)
-    (("rsautl" "-sign" "-inkey" key)
-     (sign-with-key key (current-input-port)))
-    ;; As invoked by guix-daemon.
-    (("rsautl" "-verify" "-inkey" _ "-pubin" "-in" signature-file)
-     (call-with-input-file signature-file
-       (lambda (port)
-         (validate-signature port))))
-    ;; As invoked by Nix/Crypto.pm (used by Hydra.)
-    (("rsautl" "-verify" "-inkey" _ "-pubin")
-     (validate-signature (current-input-port)))
-    (("--help")
-     (display (_ "Usage: guix authenticate OPTION...
+  ;; Signature sexps written to stdout may contain binary data, so force
+  ;; ISO-8859-1 encoding so that things are not mangled.  See
+  ;; <http://bugs.gnu.org/17312> for details.
+  (set-port-encoding! (current-output-port) "ISO-8859-1")
+  (set-port-conversion-strategy! (current-output-port) 'error)
+
+  ;; Same goes for input ports.
+  (with-fluids ((%default-port-encoding "ISO-8859-1")
+                (%default-port-conversion-strategy 'error))
+    (match args
+      ;; As invoked by guix-daemon.
+      (("rsautl" "-sign" "-inkey" key "-in" hash-file)
+       (call-with-input-file hash-file
+         (lambda (port)
+           (sign-with-key key port))))
+      ;; As invoked by Nix/Crypto.pm (used by Hydra.)
+      (("rsautl" "-sign" "-inkey" key)
+       (sign-with-key key (current-input-port)))
+      ;; As invoked by guix-daemon.
+      (("rsautl" "-verify" "-inkey" _ "-pubin" "-in" signature-file)
+       (call-with-input-file signature-file
+         (lambda (port)
+           (validate-signature port))))
+      ;; As invoked by Nix/Crypto.pm (used by Hydra.)
+      (("rsautl" "-verify" "-inkey" _ "-pubin")
+       (validate-signature (current-input-port)))
+      (("--help")
+       (display (_ "Usage: guix authenticate OPTION...
 Sign or verify the signature on the given file.  This tool is meant to
 be used internally by 'guix-daemon'.\n")))
-    (("--version")
-     (show-version-and-exit "guix authenticate"))
-    (else
-     (leave (_ "wrong arguments")))))
+      (("--version")
+       (show-version-and-exit "guix authenticate"))
+      (else
+       (leave (_ "wrong arguments"))))))
 
 ;;; authenticate.scm ends here
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index c5cae4b07a..d87cad3f23 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -443,9 +443,11 @@ success, #f otherwise."
                           "-i" (build-machine-private-key machine)
                           (build-machine-name machine)
                           "guix" "archive" "--missing")
-                    (open-input-string files))))
+                    (open-input-string files)))
+                  ((result)
+                   (get-string-all missing)))
       (for-each waitpid pids)
-      (string-tokenize (get-string-all missing))))
+      (string-tokenize result)))
 
   (with-store store
     (guard (c ((nix-protocol-error? c)
@@ -472,7 +474,9 @@ success, #f otherwise."
                 (warning (_ "failed while exporting files to '~a': ~a~%")
                          (build-machine-name machine)
                          (strerror (system-error-errno args)))))))
-        #t))))
+
+        ;; Wait for the 'lsh' process to complete.
+        (zero? (close-pipe pipe))))))
 
 (define (retrieve-files files machine)
   "Retrieve FILES from MACHINE's store, and import them."
@@ -500,7 +504,8 @@ success, #f otherwise."
                                    #:log-port (current-error-port)
                                    #:lock? #f)))
 
-             #t)))))
+             ;; Wait for the 'lsh' process to complete.
+             (zero? (close-pipe pipe)))))))
 
 
 ;;;
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 8e35612e3a..c70a4f626c 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -252,7 +252,7 @@ failure."
                 (catch 'gcry-error
                   (lambda ()
                     (string->canonical-sexp signature))
-                  (lambda (err . rest)
+                  (lambda (key proc err)
                     (leave (_ "signature is not a valid \
 s-expression: ~s~%")
                            signature))))))))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 582027244c..345d8c3e5f 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -19,13 +19,20 @@
 (define-module (guix scripts system)
   #:use-module (guix ui)
   #:use-module (guix store)
+  #:use-module (guix gexp)
   #:use-module (guix derivations)
   #:use-module (guix packages)
   #:use-module (guix utils)
   #:use-module (guix monads)
   #:use-module (guix scripts build)
+  #:use-module (guix build utils)
+  #:use-module (guix build install)
+  #:use-module (gnu system)
   #:use-module (gnu system vm)
+  #:use-module (gnu system grub)
+  #:use-module (gnu packages grub)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
   #:export (guix-system
@@ -63,6 +70,48 @@
          (leave (_ "failed to load machine file '~a': ~s~%")
                 file args))))))
 
+(define* (copy-closure store item target
+                       #:key (log-port (current-error-port)))
+  "Copy ITEM to the store under root directory TARGET and register it."
+  (let ((dest (string-append target item))
+        (refs (references store item)))
+    (format log-port "copying '~a'...~%" item)
+    (copy-recursively item dest
+                      #:log (%make-void-port "w"))
+
+    ;; Register ITEM; as a side-effect, it resets timestamps, etc.
+    (unless (register-path item
+                           #:prefix target
+                           #:references refs)
+      (leave (_ "failed to register '~a' under '~a'~%")
+             item target))))
+
+(define* (install store os-dir target
+                  #:key (log-port (current-output-port))
+                  grub? grub.cfg device)
+  "Copy OS-DIR and its dependencies to directory TARGET.  TARGET must be an
+absolute directory name since that's what 'guix-register' expects.
+
+When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG."
+  (define to-copy
+    (let ((lst (delete-duplicates (cons os-dir (references store os-dir))
+                                  string=?)))
+      (topologically-sorted store lst)))
+
+  (if (string=? target "/")
+      (warning (_ "initializing the current root file system~%"))
+      ;; Copy items to the new store.
+      (for-each (cut copy-closure store <> target #:log-port log-port)
+                to-copy))
+
+  ;; Create a bunch of additional files.
+  (format log-port "populating '~a'...~%" target)
+  (populate-root-file-system target)
+
+  (when grub?
+    (unless (install-grub grub.cfg device target)
+      (leave (_ "failed to install GRUB on device '~a'~%") device))))
+
 
 ;;;
 ;;; Options.
@@ -71,12 +120,24 @@
 (define (show-help)
   (display (_ "Usage: guix system [OPTION] ACTION FILE
 Build the operating system declared in FILE according to ACTION.\n"))
-  (display (_ "Currently the only valid values for ACTION are 'vm', which builds
-a virtual machine of the given operating system that shares the host's store,
-and 'vm-image', which builds a virtual machine image that stands alone.\n"))
+  (newline)
+  (display (_ "The valid values for ACTION are:\n"))
+  (display (_ "\
+  - 'build', build the operating system without installing anything\n"))
+  (display (_ "\
+  - 'vm', build a virtual machine image that shares the host's store\n"))
+  (display (_ "\
+  - 'vm-image', build a freestanding virtual machine image\n"))
+  (display (_ "\
+  - 'disk-image', build a disk image, suitable for a USB stick\n"))
+  (display (_ "\
+  - 'init', initialize a root file system to run GNU.\n"))
+
   (show-build-options-help)
   (display (_ "
       --image-size=SIZE  for 'vm-image', produce an image of SIZE"))
+  (display (_ "
+      --no-grub          for 'init', do not install GRUB"))
   (newline)
   (display (_ "
   -h, --help             display this help and exit"))
@@ -98,6 +159,9 @@ and 'vm-image', which builds a virtual machine image that stands alone.\n"))
                  (lambda (opt name arg result)
                    (alist-cons 'image-size (size->number arg)
                                result)))
+         (option '("no-grub") #f #f
+                 (lambda (opt name arg result)
+                   (alist-delete 'install-grub? result)))
          (option '(#\n "dry-run") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'dry-run? #t result)))
@@ -110,7 +174,8 @@ and 'vm-image', which builds a virtual machine image that stands alone.\n"))
     (build-hook? . #t)
     (max-silent-time . 3600)
     (verbosity . 0)
-    (image-size . ,(* 900 (expt 2 20)))))
+    (image-size . ,(* 900 (expt 2 20)))
+    (install-grub? . #t)))
 
 
 ;;;
@@ -125,43 +190,96 @@ and 'vm-image', which builds a virtual machine image that stands alone.\n"))
                   (leave (_ "~A: unrecognized option~%") name))
                 (lambda (arg result)
                   (if (assoc-ref result 'action)
-                      (let ((previous (assoc-ref result 'argument)))
-                        (if previous
-                            (leave (_ "~a: extraneous argument~%") previous)
-                            (alist-cons 'argument arg result)))
+                      (alist-cons 'argument arg result)
                       (let ((action (string->symbol arg)))
                         (case action
-                          ((vm)
-                           (alist-cons 'action action result))
-                          ((vm-image)
+                          ((build vm vm-image disk-image init)
                            (alist-cons 'action action result))
                           (else (leave (_ "~a: unknown action~%")
                                        action))))))
                 %default-options))
 
+  (define (match-pair car)
+    ;; Return a procedure that matches a pair with CAR.
+    (match-lambda
+     ((head . tail)
+      (and (eq? car head) tail))
+     (_ #f)))
+
+  (define (option-arguments opts)
+    ;; Extract the plain arguments from OPTS.
+    (let* ((args   (reverse (filter-map (match-pair 'argument) opts)))
+           (count  (length args))
+           (action (assoc-ref opts 'action)))
+      (define (fail)
+        (leave (_ "wrong number of arguments for action '~a'~%")
+               action))
+
+      (case action
+        ((build vm vm-image disk-image)
+         (unless (= count 1)
+           (fail)))
+        ((init)
+         (unless (= count 2)
+           (fail))))
+      args))
+
   (with-error-handling
-    (let* ((opts   (parse-options))
-           (file   (assoc-ref opts 'argument))
-           (action (assoc-ref opts 'action))
-           (os     (if file
-                       (read-operating-system file)
-                       (leave (_ "no configuration file specified~%"))))
-           (mdrv   (case action
-                     ((vm-image)
-                      (let ((size (assoc-ref opts 'image-size)))
-                        (system-qemu-image os
-                                           #:disk-image-size size)))
-                     ((vm)
-                      (system-qemu-image/shared-store-script os))))
-           (store  (open-connection))
-           (dry?   (assoc-ref opts 'dry-run?))
-           (drv    (run-with-store store mdrv)))
+    (let* ((opts     (parse-options))
+           (args     (option-arguments opts))
+           (file     (first args))
+           (action   (assoc-ref opts 'action))
+           (os       (if file
+                         (read-operating-system file)
+                         (leave (_ "no configuration file specified~%"))))
+           (mdrv     (case action
+                       ((build init)
+                        (operating-system-derivation os))
+                       ((vm-image)
+                        (let ((size (assoc-ref opts 'image-size)))
+                          (system-qemu-image os
+                                             #:disk-image-size size)))
+                       ((vm)
+                        (system-qemu-image/shared-store-script os))
+                       ((disk-image)
+                        (let ((size (assoc-ref opts 'image-size)))
+                          (system-disk-image os
+                                             #:disk-image-size size)))))
+           (store    (open-connection))
+           (dry?     (assoc-ref opts 'dry-run?))
+           (drv      (run-with-store store mdrv))
+           (grub?    (assoc-ref opts 'install-grub?))
+           (grub.cfg (run-with-store store
+                       (operating-system-grub.cfg os)))
+           (grub     (package-derivation store grub))
+           (drv-lst  (if grub?
+                         (list drv grub grub.cfg)
+                         (list drv))))
       (set-build-options-from-command-line store opts)
-      (show-what-to-build store (list drv)
+      (show-what-to-build store drv-lst
                           #:dry-run? dry?
                           #:use-substitutes? (assoc-ref opts 'substitutes?))
 
       (unless dry?
-        (build-derivations store (list drv))
+        (build-derivations store drv-lst)
         (display (derivation->output-path drv))
-        (newline)))))
+        (newline)
+
+        (when (eq? action 'init)
+          (let* ((target (second args))
+                 (device (grub-configuration-device
+                          (operating-system-bootloader os))))
+            (format #t (_ "initializing operating system under '~a'...~%")
+                    target)
+
+            (when grub
+              (let ((prefix (derivation->output-path grub)))
+                (setenv "PATH"
+                        (string-append  prefix "/bin:" prefix "/sbin:"
+                                        (getenv "PATH")))))
+
+            (install store (derivation->output-path drv)
+                     (canonicalize-path target)
+                     #:grub? grub?
+                     #:grub.cfg (derivation->output-path grub.cfg)
+                     #:device device)))))))
diff --git a/guix/store.scm b/guix/store.scm
index c1898c5c81..8c774a6db2 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -291,16 +291,6 @@ operate, should the disk become full.  Return a server object."
         (a (make-socket-address PF_UNIX file)))
 
     (catch 'system-error
-      (lambda ()
-        ;; Enlarge the receive buffer.
-        (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024)))
-      (lambda args
-        ;; On the Hurd, the pflocal server's implementation of `socket_setopt'
-        ;; always returns ENOPROTOOPT.  Ignore it.
-        (unless (= (system-error-errno args) ENOPROTOOPT)
-          (apply throw args))))
-
-    (catch 'system-error
       (cut connect s a)
       (lambda args
         ;; Translate the error to something user-friendly.
@@ -370,6 +360,12 @@ to OUT, using chunks of BUFFER-SIZE bytes."
                                        (min (- len total) buffer-size)
                                        buffer-size)))))))
 
+(define %newlines
+  ;; Newline characters triggering a flush of 'current-build-output-port'.
+  ;; Unlike Guile's _IOLBF, we flush upon #\return so that progress reports
+  ;; that use that trick are correctly displayed.
+  (char-set #\newline #\return))
+
 (define* (process-stderr server #:optional user-port)
   "Read standard output and standard error from SERVER, writing it to
 CURRENT-BUILD-OUTPUT-PORT.  Return #t when SERVER is done sending data, and
@@ -401,17 +397,21 @@ encoding conversion errors."
            #f)
           ((= k %stderr-read)
            ;; Read a byte stream from USER-PORT.
+           ;; Note: Avoid 'get-bytevector-n' to work around
+           ;; <http://bugs.gnu.org/17591> in Guile up to 2.0.11.
            (let* ((max-len (read-int p))
-                  (data    (get-bytevector-n user-port max-len))
-                  (len     (bytevector-length data)))
+                  (data    (make-bytevector max-len))
+                  (len     (get-bytevector-n! user-port data 0 max-len)))
              (write-int len p)
-             (put-bytevector p data)
+             (put-bytevector p data 0 len)
              (write-padding len p)
              #f))
           ((= k %stderr-next)
            ;; Log a string.
            (let ((s (read-latin1-string p)))
              (display s (current-build-output-port))
+             (when (string-any %newlines s)
+               (flush-output-port (current-build-output-port)))
              #f))
           ((= k %stderr-error)
            ;; Report an error.
@@ -797,17 +797,21 @@ signing them if SIGN? is true."
               (loop tail)))))))
 
 (define* (register-path path
-                        #:key (references '()) deriver)
+                        #:key (references '()) deriver prefix)
   "Register PATH as a valid store file, with REFERENCES as its list of
-references, and DERIVER as its deriver (.drv that led to it.)  Return #t on
-success.
+references, and DERIVER as its deriver (.drv that led to it.)  If PREFIX is
+not #f, it must be the name of the directory containing the new store to
+initialize.  Return #t on success.
 
 Use with care as it directly modifies the store!  This is primarily meant to
 be used internally by the daemon's build hook."
   ;; Currently this is implemented by calling out to the fine C++ blob.
   (catch 'system-error
     (lambda ()
-      (let ((pipe (open-pipe* OPEN_WRITE %guix-register-program)))
+      (let ((pipe (apply open-pipe* OPEN_WRITE %guix-register-program
+                         (if prefix
+                             `("--prefix" ,prefix)
+                             '()))))
         (and pipe
              (begin
                (format pipe "~a~%~a~%~a~%"
@@ -839,6 +843,7 @@ be used internally by the daemon's build hook."
 This predicate is sometimes needed because files *under* a store path are not
 valid inputs."
   (and (store-path? path)
+       (not (string=? path (%store-prefix)))
        (let ((len (+ 1 (string-length (%store-prefix)))))
          (not (string-index (substring path len) #\/)))))
 
diff --git a/guix/ui.scm b/guix/ui.scm
index 944c9f87fa..48b5c745c6 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -241,7 +241,7 @@ interpreted."
                         str args)))))
     (catch #t
       (lambda ()
-        (eval exp the-scm-module))
+        (eval exp the-root-module))
       (lambda args
         (leave (_ "failed to evaluate expression `~a': ~s~%")
                exp args)))))
@@ -261,6 +261,14 @@ error."
 derivations listed in DRV.  Return #t if there's something to build, #f
 otherwise.  When USE-SUBSTITUTES?, check and report what is prerequisites are
 available for download."
+  (define (built-or-substitutable? drv)
+    (let ((out (derivation->output-path drv)))
+      ;; If DRV has zero outputs, OUT is #f.
+      (or (not out)
+          (or (valid-path? store out)
+              (and use-substitutes?
+                   (has-substitutes? store out))))))
+
   (let*-values (((build download)
                  (fold2 (lambda (drv build download)
                           (let-values (((b d)
@@ -275,14 +283,7 @@ available for download."
                 ((build)                          ; add the DRV themselves
                  (delete-duplicates
                   (append (map derivation-file-name
-                               (remove (lambda (drv)
-                                         (let ((out (derivation->output-path
-                                                     drv)))
-                                           (or (valid-path? store out)
-                                               (and use-substitutes?
-                                                    (has-substitutes? store
-                                                                      out)))))
-                                       drv))
+                               (remove built-or-substitutable? drv))
                           (map derivation-input-path build))))
                 ((download)                   ; add the references of DOWNLOAD
                  (if use-substitutes?
diff --git a/guix/utils.scm b/guix/utils.scm
index 84cb5ae983..700a191d71 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -28,6 +28,7 @@
   #:use-module (rnrs bytevectors)
   #:use-module ((rnrs io ports) #:select (put-bytevector))
   #:use-module ((guix build utils) #:select (dump-port))
+  #:use-module ((guix build syscalls) #:select (errno))
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 format)
   #:autoload   (ice-9 popen)  (open-pipe*)
@@ -229,14 +230,12 @@ a symbol such as 'xz."
 
 (define (call-with-decompressed-port compression port proc)
   "Call PROC with a wrapper around PORT, a file port, that decompresses data
-read from PORT according to COMPRESSION, a symbol such as 'xz.  PORT is closed
-as soon as PROC's dynamic extent is entered."
+read from PORT according to COMPRESSION, a symbol such as 'xz."
   (let-values (((decompressed pids)
                 (decompressed-port compression port)))
     (dynamic-wind
       (const #f)
       (lambda ()
-        (close-port port)
         (proc decompressed))
       (lambda ()
         (close-port decompressed)
@@ -286,14 +285,12 @@ of PIDs to wait for."
 
 (define (call-with-compressed-output-port compression port proc)
   "Call PROC with a wrapper around PORT, a file port, that compresses data
-that goes to PORT according to COMPRESSION, a symbol such as 'xz.  PORT is
-closed as soon as PROC's dynamic extent is entered."
+that goes to PORT according to COMPRESSION, a symbol such as 'xz."
   (let-values (((compressed pids)
                 (compressed-output-port compression port)))
     (dynamic-wind
       (const #f)
       (lambda ()
-        (close-port port)
         (proc compressed))
       (lambda ()
         (close-port compressed)
@@ -370,38 +367,6 @@ closed as soon as PROC's dynamic extent is entered."
          ((string-contains %host-type "linux") #(0 1 2))    ; *-linux-gnu
          (else                                 #(1 2 3))))) ; *-gnu*
 
-(define %libc-errno-pointer
-  ;; Glibc's 'errno' pointer.
-  (let ((errno-loc (dynamic-func "__errno_location" (dynamic-link))))
-    (and errno-loc
-         (let ((proc (pointer->procedure '* errno-loc '())))
-           (proc)))))
-
-(define errno
-  (if %libc-errno-pointer
-      (let ((bv (pointer->bytevector %libc-errno-pointer (sizeof int))))
-        (lambda ()
-          "Return the current errno."
-          ;; XXX: We assume that nothing changes 'errno' while we're doing all this.
-          ;; In particular, that means that no async must be running here.
-
-          ;; Use one of the fixed-size native-ref procedures because they are
-          ;; optimized down to a single VM instruction, which reduces the risk
-          ;; that we fiddle with 'errno' (needed on Guile 2.0.5, libc 2.11.)
-          (let-syntax ((ref (lambda (s)
-                              (syntax-case s ()
-                                ((_ bv)
-                                 (case (sizeof int)
-                                   ((4)
-                                    #'(bytevector-s32-native-ref bv 0))
-                                   ((8)
-                                    #'(bytevector-s64-native-ref bv 0))
-                                   (else
-                                    (error "unsupported 'int' size"
-                                           (sizeof int)))))))))
-            (ref bv))))
-      (lambda () 0)))
-
 (define fcntl-flock
   (let* ((ptr  (dynamic-func "fcntl" (dynamic-link)))
          (proc (pointer->procedure int ptr `(,int ,int *))))