Merge branch 'master' into core-updates

Conflicts:
	gnu-system.am

4 files changed, 387 insertions, 387 deletions

diff --git a/gnu/system/dmd.scm b/gnu/system/dmd.scm
deleted file mode 100644
index 2143b00426..0000000000
--- a/gnu/system/dmd.scm
+++ /dev/null
@@ -1,316 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; GNU Guix is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; GNU Guix is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
-
-(define-module (gnu system dmd)
-  #:use-module (guix store)
-  #:use-module (guix packages)
-  #:use-module (guix derivations)
-  #:use-module (guix records)
-  #:use-module ((gnu packages base)
-                #:select (glibc-final))
-  #:use-module ((gnu packages admin)
-                #:select (mingetty inetutils shadow))
-  #:use-module ((gnu packages package-management)
-                #:select (guix))
-  #:use-module ((gnu packages linux)
-                #:select (net-tools))
-  #:use-module (gnu system shadow)                ; for user accounts/groups
-  #:use-module (gnu system linux)                 ; for PAM services
-  #:use-module (ice-9 match)
-  #:use-module (ice-9 format)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-26)
-  #:use-module (guix monads)
-  #:export (service?
-            service
-            service-provision
-            service-requirement
-            service-respawn?
-            service-start
-            service-stop
-            service-inputs
-            service-user-accounts
-            service-user-groups
-            service-pam-services
-
-            host-name-service
-            syslog-service
-            mingetty-service
-            nscd-service
-            guix-service
-            static-networking-service
-
-            dmd-configuration-file))
-
-;;; Commentary:
-;;;
-;;; System services as cajoled by dmd.
-;;;
-;;; Code:
-
-(define-record-type* <service>
-  service make-service
-  service?
-  (documentation service-documentation            ; string
-                 (default "[No documentation.]"))
-  (provision     service-provision)               ; list of symbols
-  (requirement   service-requirement              ; list of symbols
-                 (default '()))
-  (respawn?      service-respawn?                 ; Boolean
-                 (default #t))
-  (start         service-start)                   ; expression
-  (stop          service-stop                     ; expression
-                 (default #f))
-  (inputs        service-inputs                   ; list of inputs
-                 (default '()))
-  (user-accounts service-user-accounts            ; list of <user-account>
-                 (default '()))
-  (user-groups   service-user-groups              ; list of <user-groups>
-                 (default '()))
-  (pam-services  service-pam-services             ; list of <pam-service>
-                 (default '())))
-
-(define (host-name-service name)
-  "Return a service that sets the host name to NAME."
-  (with-monad %store-monad
-    (return (service
-             (documentation "Initialize the machine's host name.")
-             (provision '(host-name))
-             (start `(lambda _
-                       (sethostname ,name)))
-             (respawn? #f)))))
-
-(define* (mingetty-service tty
-                           #:key
-                           (motd (text-file "motd" "Welcome.\n"))
-                           (allow-empty-passwords? #t))
-  "Return a service to run mingetty on TTY."
-  (mlet %store-monad ((mingetty-bin (package-file mingetty "sbin/mingetty"))
-                      (motd         motd))
-    (return
-     (service
-      (documentation (string-append "Run mingetty on " tty "."))
-      (provision (list (symbol-append 'term- (string->symbol tty))))
-
-      ;; Since the login prompt shows the host name, wait for the 'host-name'
-      ;; service to be done.
-      (requirement '(host-name))
-
-      (start  `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty))
-      (stop   `(make-kill-destructor))
-      (inputs `(("mingetty" ,mingetty)
-                ("motd" ,motd)))
-
-      (pam-services
-       ;; Let 'login' be known to PAM.  All the mingetty services will have
-       ;; that PAM service, but that's fine because they're all identical and
-       ;; duplicates are removed.
-       (list (unix-pam-service "login"
-                               #:allow-empty-passwords? allow-empty-passwords?
-                               #:motd motd)))))))
-
-(define* (nscd-service #:key (glibc glibc-final))
-  "Return a service that runs libc's name service cache daemon (nscd)."
-  (mlet %store-monad ((nscd (package-file glibc "sbin/nscd")))
-    (return (service
-             (documentation "Run libc's name service cache daemon (nscd).")
-             (provision '(nscd))
-             (start `(make-forkexec-constructor ,nscd "-f" "/dev/null"
-                                                "--foreground"))
-             (stop  `(make-kill-destructor))
-
-             (respawn? #f)
-             (inputs `(("glibc" ,glibc)))))))
-
-(define (syslog-service)
-  "Return a service that runs 'syslogd' with reasonable default settings."
-
-  ;; Snippet adapted from the GNU inetutils manual.
-  (define contents "
-     # Log all kernel messages, authentication messages of
-     # level notice or higher and anything of level err or
-     # higher to the console.
-     # Don't log private authentication messages!
-     *.err;kern.*;auth.notice;authpriv.none  /dev/console
-
-     # Log anything (except mail) of level info or higher.
-     # Don't log private authentication messages!
-     *.info;mail.none;authpriv.none          /var/log/messages
-
-     # Same, in a different place.
-     *.info;mail.none;authpriv.none          /dev/tty12
-
-     # The authpriv file has restricted access.
-     authpriv.*                              /var/log/secure
-
-     # Log all the mail messages in one place.
-     mail.*                                  /var/log/maillog
-")
-
-  (mlet %store-monad
-      ((syslog.conf (text-file "syslog.conf" contents))
-       (syslogd     (package-file inetutils "libexec/syslogd")))
-    (return
-     (service
-      (documentation "Run the syslog daemon (syslogd).")
-      (provision '(syslogd))
-      (start `(make-forkexec-constructor ,syslogd "--no-detach"
-                                         "--rcfile" ,syslog.conf))
-      (stop  `(make-kill-destructor))
-      (inputs `(("inetutils" ,inetutils)
-                ("syslog.conf" ,syslog.conf)))))))
-
-(define* (guix-build-accounts count #:key
-                              (first-uid 30001)
-                              (gid 30000)
-                              (shadow shadow))
-  "Return a list of COUNT user accounts for Guix build users, with UIDs
-starting at FIRST-UID, and under GID."
-  (with-monad %store-monad
-    (return (unfold (cut > <> count)
-                    (lambda (n)
-                      (user-account
-                       (name (format #f "guixbuilder~2,'0d" n))
-                       (password "!")
-                       (uid (+ first-uid n -1))
-                       (gid gid)
-                       (comment (format #f "Guix Build User ~2d" n))
-                       (home-directory "/var/empty")
-                       (shell (package-file shadow "sbin/nologin"))
-                       (inputs `(("shadow" ,shadow)))))
-                    1+
-                    1))))
-
-(define* (guix-service #:key (guix guix) (builder-group "guixbuild")
-                       (build-user-gid 30000) (build-accounts 10))
-  "Return a service that runs the build daemon from GUIX, and has
-BUILD-ACCOUNTS user accounts available under BUILD-USER-GID."
-  (mlet %store-monad ((daemon   (package-file guix "bin/guix-daemon"))
-                      (accounts (guix-build-accounts build-accounts
-                                                     #:gid build-user-gid)))
-    (return (service
-             (provision '(guix-daemon))
-             (start `(make-forkexec-constructor ,daemon
-                                                "--build-users-group"
-                                                ,builder-group))
-             (stop  `(make-kill-destructor))
-             (inputs `(("guix" ,guix)))
-             (user-accounts accounts)
-             (user-groups (list (user-group
-                                 (name builder-group)
-                                 (id build-user-gid)
-                                 (members (map user-account-name
-                                               user-accounts)))))))))
-
-(define* (static-networking-service interface ip
-                                    #:key
-                                    gateway
-                                    (name-servers '())
-                                    (inetutils inetutils)
-                                    (net-tools net-tools))
-  "Return a service that starts INTERFACE with address IP.  If GATEWAY is
-true, it must be a string specifying the default network gateway."
-
-  ;; TODO: Eventually we should do this using Guile's networking procedures,
-  ;; like 'configure-qemu-networking' does, but the patch that does this is
-  ;; not yet in stock Guile.
-  (mlet %store-monad ((ifconfig (package-file inetutils "bin/ifconfig"))
-                      (route    (package-file net-tools "sbin/route")))
-    (return
-     (service
-      (documentation
-       (string-append "Set up networking on the '" interface
-                      "' interface using a static IP address."))
-      (provision '(networking))
-      (start `(lambda _
-                ;; Return #t if successfully started.
-                (and (zero? (system* ,ifconfig ,interface ,ip "up"))
-                     ,(if gateway
-                          `(zero? (system* ,route "add" "-net" "default"
-                                           "gw" ,gateway))
-                          #t)
-                     ,(if (pair? name-servers)
-                          `(call-with-output-file "/etc/resolv.conf"
-                             (lambda (port)
-                               (display
-                                "# Generated by 'static-networking-service'.\n"
-                                port)
-                               (for-each (lambda (server)
-                                           (format port "nameserver ~a~%"
-                                                   server))
-                                         ',name-servers)))
-                          #t))))
-      (stop  `(lambda _
-                ;; Return #f is successfully stopped.
-                (not (and (system* ,ifconfig ,interface "down")
-                          (system* ,route "del" "-net" "default")))))
-      (respawn? #f)
-      (inputs `(("inetutils" ,inetutils)
-                ,@(if gateway
-                      `(("net-tools" ,net-tools))
-                      '())))))))
-
-
-(define (dmd-configuration-file services etc)
-  "Return the dmd configuration file for SERVICES, that initializes /etc from
-ETC on startup."
-  (define config
-    `(begin
-       (use-modules (ice-9 ftw))
-
-       (register-services
-        ,@(map (match-lambda
-                (($ <service> documentation provision requirement
-                    respawn? start stop)
-                 `(make <service>
-                    #:docstring ,documentation
-                    #:provides ',provision
-                    #:requires ',requirement
-                    #:respawn? ,respawn?
-                    #:start ,start
-                    #:stop ,stop)))
-               services))
-
-       ;; /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 '("." ".."))))))
-
-         ;; Prevent ETC from being GC'd.
-         (rm-f "/var/nix/gcroots/etc-directory")
-         (symlink ,etc "/var/nix/gcroots/etc-directory"))
-
-       (format #t "starting services...~%")
-       (for-each start ',(append-map service-provision services))))
-
-  (text-file "dmd.conf" (object->string config)))
-
-;;; dmd.scm ends here
diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm
index 86fa9b504d..5dc0b85ff2 100644
--- a/gnu/system/grub.scm
+++ b/gnu/system/grub.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -41,7 +41,7 @@
   (linux           menu-entry-linux)
   (linux-arguments menu-entry-linux-arguments
                    (default '()))
-  (initrd          menu-entry-initrd))
+  (initrd          menu-entry-initrd))            ; file name of the initrd
 
 (define* (grub-configuration-file entries
                                   #:key (default-entry 1) (timeout 5)
@@ -66,10 +66,7 @@ search.file ~a~%"
     (match-lambda
      (($ <menu-entry> label linux arguments initrd)
       (mlet %store-monad ((linux  (package-file linux "bzImage"
-                                                #:system system))
-                          (initrd (package-file initrd "initrd"
                                                 #:system system)))
-        ;; XXX: Assume that INITRD is a directory containing an 'initrd' file.
         (return (format #f "menuentry ~s {
   linux ~a ~a
   initrd ~a
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
new file mode 100644
index 0000000000..9520473d01
--- /dev/null
+++ b/gnu/system/linux-initrd.scm
@@ -0,0 +1,248 @@
+;;; 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 (gnu system linux-initrd)
+  #:use-module (guix monads)
+  #:use-module (guix utils)
+  #:use-module ((guix store)
+                #:select (%store-prefix))
+  #:use-module (gnu packages cpio)
+  #:use-module (gnu packages compression)
+  #:use-module (gnu packages linux)
+  #:use-module (gnu packages guile)
+  #:use-module ((gnu packages make-bootstrap)
+                #:select (%guile-static-stripped))
+  #:use-module (ice-9 regex)
+  #:export (expression->initrd
+            qemu-initrd
+            gnu-system-initrd))
+
+
+;;; Commentary:
+;;;
+;;; Tools to build initial RAM disks (initrd's) for Linux-Libre, and in
+;;; particular initrd's that run Guile.
+;;;
+;;; Code:
+
+
+(define* (expression->initrd exp
+                             #:key
+                             (guile %guile-static-stripped)
+                             (cpio cpio)
+                             (gzip gzip)
+                             (name "guile-initrd")
+                             (system (%current-system))
+                             (modules '())
+                             (linux #f)
+                             (linux-modules '()))
+  "Return a package that contains a Linux initrd (a gzipped cpio archive)
+containing GUILE and that evaluates EXP upon booting.  LINUX-MODULES is a list
+of `.ko' file names to be copied from LINUX into the initrd.  MODULES is a
+list of Guile module names to be embedded in the initrd."
+
+  ;; General Linux overview in `Documentation/early-userspace/README' and
+  ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'.
+
+  (define (string->regexp str)
+    ;; Return a regexp that matches STR exactly.
+    (string-append "^" (regexp-quote str) "$"))
+
+  (define builder
+    `(begin
+       (use-modules (guix build utils)
+                    (ice-9 pretty-print)
+                    (ice-9 popen)
+                    (ice-9 match)
+                    (ice-9 ftw)
+                    (srfi srfi-26)
+                    (system base compile)
+                    (rnrs bytevectors)
+                    ((system foreign) #:select (sizeof)))
+
+       (let ((guile   (assoc-ref %build-inputs "guile"))
+             (cpio    (string-append (assoc-ref %build-inputs "cpio")
+                                     "/bin/cpio"))
+             (gzip    (string-append (assoc-ref %build-inputs "gzip")
+                                     "/bin/gzip"))
+             (modules (assoc-ref %build-inputs "modules"))
+             (gos     (assoc-ref %build-inputs "modules/compiled"))
+             (scm-dir (string-append "share/guile/" (effective-version)))
+             (go-dir  (format #f ".cache/guile/ccache/~a-~a-~a-~a"
+                              (effective-version)
+                              (if (eq? (native-endianness) (endianness little))
+                                  "LE"
+                                  "BE")
+                              (sizeof '*)
+                              (effective-version)))
+             (out     (assoc-ref %outputs "out")))
+         (mkdir out)
+         (mkdir "contents")
+         (with-directory-excursion "contents"
+           (copy-recursively guile ".")
+           (call-with-output-file "init"
+             (lambda (p)
+               (format p "#!/bin/guile -ds~%!#~%" guile)
+               (pretty-print ',exp p)))
+           (chmod "init" #o555)
+           (chmod "bin/guile" #o555)
+
+           ;; Copy Guile modules.
+           (chmod scm-dir #o777)
+           (copy-recursively modules scm-dir
+                             #:follow-symlinks? #t)
+           (copy-recursively gos (string-append "lib/guile/"
+                                                (effective-version) "/ccache")
+                             #:follow-symlinks? #t)
+
+           ;; Compile `init'.
+           (mkdir-p go-dir)
+           (set! %load-path (cons modules %load-path))
+           (set! %load-compiled-path (cons gos %load-compiled-path))
+           (compile-file "init"
+                         #:opts %auto-compilation-options
+                         #:output-file (string-append go-dir "/init.go"))
+
+           ;; Copy Linux modules.
+           (let* ((linux      (assoc-ref %build-inputs "linux"))
+                  (module-dir (and linux
+                                   (string-append linux "/lib/modules"))))
+             (mkdir "modules")
+             ,@(map (lambda (module)
+                      `(match (find-files module-dir
+                                          ,(string->regexp module))
+                         ((file)
+                          (format #t "copying '~a'...~%" file)
+                          (copy-file file (string-append "modules/"
+                                                         ,module)))
+                         (()
+                          (error "module not found" ,module module-dir))
+                         ((_ ...)
+                          (error "several modules by that name"
+                                 ,module module-dir))))
+                    linux-modules))
+
+           ;; Reset the timestamps of all the files that will make it in the
+           ;; initrd.
+           (for-each (cut utime <> 0 0 0 0)
+                     (find-files "." ".*"))
+
+           (system* cpio "--version")
+           (let ((pipe (open-pipe* OPEN_WRITE cpio "-o"
+                                   "-O" (string-append out "/initrd")
+                                   "-H" "newc" "--null")))
+             (define print0
+               (let ((len (string-length "./")))
+                 (lambda (file)
+                   (format pipe "~a\0" (string-drop file len)))))
+
+             ;; Note: as per `ramfs-rootfs-initramfs.txt', always add
+             ;; directory entries before the files that are inside of it: "The
+             ;; Linux kernel cpio extractor won't create files in a directory
+             ;; that doesn't exist, so the directory entries must go before
+             ;; the files that go in those directories."
+             (file-system-fold (const #t)
+                               (lambda (file stat result) ; leaf
+                                 (print0 file))
+                               (lambda (dir stat result) ; down
+                                 (unless (string=? dir ".")
+                                   (print0 dir)))
+                               (const #f)         ; up
+                               (const #f)         ; skip
+                               (const #f)
+                               #f
+                               ".")
+
+             (and (zero? (close-pipe pipe))
+                  (with-directory-excursion out
+                    (and (zero? (system* gzip "--best" "initrd"))
+                         (rename-file "initrd.gz" "initrd")))))))))
+
+  (mlet* %store-monad
+      ((source   (imported-modules modules))
+       (compiled (compiled-modules modules))
+       (inputs   (lower-inputs
+                  `(("guile" ,guile)
+                    ("cpio" ,cpio)
+                    ("gzip" ,gzip)
+                    ("modules" ,source)
+                    ("modules/compiled" ,compiled)
+                    ,@(if linux
+                          `(("linux" ,linux))
+                          '())))))
+   (derivation-expression name builder
+                          #:modules '((guix build utils))
+                          #:inputs inputs)))
+
+(define* (qemu-initrd #:key
+                      guile-modules-in-chroot?
+                      volatile-root?
+                      (mounts `((cifs "/store" ,(%store-prefix))
+                                (cifs "/xchg" "/xchg"))))
+  "Return a monadic derivation that builds an initrd for use in a QEMU guest
+where the store is shared with the host.  MOUNTS is a list of file systems to
+be mounted atop the root file system, where each item has the form:
+
+    (FILE-SYSTEM-TYPE SOURCE TARGET)
+
+When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in
+the new root.  This is necessary is the file specified as '--load' needs
+access to these modules (which is the case if it wants to even just print an
+exception and backtrace!).
+
+When VOLATILE-ROOT? is true, the root file system is writable but any changes
+to it are lost."
+  (define cifs-modules
+    ;; Modules needed to mount CIFS file systems.
+    '("md4.ko" "ecb.ko" "cifs.ko"))
+
+  (define virtio-9p-modules
+    ;; Modules for the 9p paravirtualized file system.
+    '("9pnet.ko" "9p.ko" "9pnet_virtio.ko"))
+
+  (define linux-modules
+    ;; Modules added to the initrd and loaded from the initrd.
+    `("virtio.ko" "virtio_ring.ko" "virtio_pci.ko"
+      "virtio_balloon.ko" "virtio_blk.ko" "virtio_net.ko"
+      ,@(if (assoc-ref mounts 'cifs)
+            cifs-modules
+            '())
+      ,@(if (assoc-ref mounts '9p)
+            virtio-9p-modules
+            '())))
+
+  (expression->initrd
+   `(begin
+      (use-modules (guix build linux-initrd))
+
+      (boot-system #:mounts ',mounts
+                   #:linux-modules ',linux-modules
+                   #:qemu-guest-networking? #t
+                   #:guile-modules-in-chroot? ',guile-modules-in-chroot?
+                   #:volatile-root? ',volatile-root?))
+   #:name "qemu-initrd"
+   #:modules '((guix build utils)
+               (guix build linux-initrd))
+   #:linux linux-libre
+   #:linux-modules linux-modules))
+
+(define (gnu-system-initrd)
+  "Initrd for the GNU system itself, with nothing QEMU-specific."
+  (qemu-initrd #:guile-modules-in-chroot? #f))
+
+;;; linux-initrd.scm ends here
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index e75c09d859..b8b0274f1f 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -35,7 +35,6 @@
   #:use-module (gnu packages zile)
   #:use-module (gnu packages grub)
   #:use-module (gnu packages linux)
-  #:use-module (gnu packages linux-initrd)
   #:use-module (gnu packages package-management)
   #:use-module ((gnu packages make-bootstrap)
                 #:select (%guile-static-stripped))
@@ -43,9 +42,10 @@
 
   #:use-module (gnu system shadow)
   #:use-module (gnu system linux)
+  #:use-module (gnu system linux-initrd)
   #:use-module (gnu system grub)
-  #:use-module (gnu system dmd)
   #:use-module (gnu system)
+  #:use-module (gnu services)
 
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
@@ -53,7 +53,9 @@
 
   #:export (expression->derivation-in-linux-vm
             qemu-image
-            system-qemu-image))
+            system-qemu-image
+            system-qemu-image/shared-store
+            system-qemu-image/shared-store-script))
 
 
 ;;; Commentary:
@@ -67,7 +69,7 @@
                                              (system (%current-system))
                                              (inputs '())
                                              (linux linux-libre)
-                                             (initrd qemu-initrd)
+                                             initrd
                                              (qemu qemu/smb-shares)
                                              (env-vars '())
                                              (modules '())
@@ -78,10 +80,10 @@
                                              (references-graphs #f)
                                              (disk-image-size
                                               (* 100 (expt 2 20))))
-  "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD.  In the
-virtual machine, EXP has access to all of INPUTS from the store; it should put
-its output files in the `/xchg' directory, which is copied to the derivation's
-output when the VM terminates.
+  "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
+derivation).  In the virtual machine, EXP has access to all of INPUTS from the
+store; it should put its output files in the `/xchg' directory, which is
+copied to the derivation's output when the VM terminates.
 
 When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of
 DISK-IMAGE-SIZE bytes and return it.
@@ -154,7 +156,7 @@ made available under the /xchg CIFS share."
                (#f '())))
 
          (and (zero?
-               (system* qemu "-nographic" "-no-reboot"
+               (system* qemu "-enable-kvm" "-nographic" "-no-reboot"
                         "-net" "nic,model=e1000"
                         "-net" (string-append "user,smb=" (getcwd))
                         "-kernel" linux
@@ -178,6 +180,9 @@ made available under the /xchg CIFS share."
        (user-builder (text-file "builder-in-linux-vm"
                                 (object->string exp*)))
        (coreutils -> (car (assoc-ref %final-inputs "coreutils")))
+       (initrd       (if initrd                   ; use the default initrd?
+                         (return initrd)
+                         (qemu-initrd #:guile-modules-in-chroot? #t)))
        (inputs       (lower-inputs `(("qemu" ,qemu)
                                      ("linux" ,linux)
                                      ("initrd" ,initrd)
@@ -185,6 +190,7 @@ made available under the /xchg CIFS share."
                                      ("builder" ,user-builder)
                                      ,@inputs))))
     (derivation-expression name builder
+                           ;; TODO: Require the "kvm" feature.
                            #:system system
                            #:inputs inputs
                            #:env-vars env-vars
@@ -290,18 +296,18 @@ such as /etc files."
                                 (assoc-ref %build-inputs "gawk") "/bin"))
 
          (display "creating partition table...\n")
-         (and (zero? (system* parted "/dev/vda" "mklabel" "msdos"
+         (and (zero? (system* parted "/dev/sda" "mklabel" "msdos"
                               "mkpart" "primary" "ext2" "1MiB"
                               ,(format #f "~aB"
                                        (- disk-image-size
                                           (* 5 (expt 2 20))))))
               (begin
                 (display "creating ext3 partition...\n")
-                (and (zero? (system* mkfs "-F" "/dev/vda1"))
+                (and (zero? (system* mkfs "-F" "/dev/sda1"))
                      (let ((store (string-append "/fs" ,%store-directory)))
                        (display "mounting partition...\n")
                        (mkdir "/fs")
-                       (mount "/dev/vda1" "/fs" "ext3")
+                       (mount "/dev/sda1" "/fs" "ext3")
                        (mkdir-p "/fs/boot/grub")
                        (symlink grub.cfg "/fs/boot/grub/grub.cfg")
 
@@ -319,8 +325,9 @@ such as /etc files."
 
                        ;; Optionally, register the inputs in the image's store.
                        (let* ((guix     (assoc-ref %build-inputs "guix"))
-                              (register (string-append guix
-                                                       "/sbin/guix-register")))
+                              (register (and guix
+                                             (string-append guix
+                                                            "/sbin/guix-register"))))
                          ,@(if initialize-store?
                                (match inputs-to-copy
                                  (((graph-files . _) ...)
@@ -375,7 +382,7 @@ such as /etc files."
                        (and (zero?
                              (system* grub "--no-floppy"
                                       "--boot-directory" "/fs/boot"
-                                      "/dev/vda"))
+                                      "/dev/sda"))
                             (zero? (system* umount "/fs"))
                             (reboot))))))))
     #:system system
@@ -407,37 +414,52 @@ such as /etc files."
 ;;; Stand-alone VM image.
 ;;;
 
-(define %demo-operating-system
-  (operating-system
-   (host-name "gnu")
-   (timezone "Europe/Paris")
-   (locale "en_US.UTF-8")
-   (users (list (user-account
-                 (name "guest")
-                 (password "")
-                 (uid 1000) (gid 100)
-                 (comment "Guest of GNU")
-                 (home-directory "/home/guest"))))
-   (packages (list coreutils
-                   bash
-                   guile-2.0
-                   dmd
-                   gcc-final
-                   ld-wrapper                    ; must come before BINUTILS
-                   binutils-final
-                   glibc-final
-                   inetutils
-                   findutils
-                   grep
-                   sed
-                   procps
-                   psmisc
-                   zile
-                   less
-                   tzdata
-                   guix))))
-
-(define* (system-qemu-image #:optional (os %demo-operating-system)
+(define (operating-system-build-gid os)
+  "Return as a monadic value the group id for build users of OS, or #f."
+  (anym %store-monad
+        (lambda (service)
+          (and (equal? '(guix-daemon)
+                       (service-provision service))
+               (match (service-user-groups service)
+                 ((group)
+                  (user-group-id group)))))
+        (operating-system-services os)))
+
+(define (operating-system-default-contents os)
+  "Return a list of directives suitable for 'system-qemu-image' describing the
+basic contents of the root file system of OS."
+  (define (user-directories user)
+    (let ((home (user-account-home-directory user))
+          ;; XXX: Deal with automatically allocated ids.
+          (uid  (or (user-account-uid user) 0))
+          (gid  (or (user-account-gid user) 0))
+          (root (string-append "/var/nix/profiles/per-user/"
+                               (user-account-name user))))
+      `((directory ,root ,uid ,gid)
+        (directory ,home ,uid ,gid))))
+
+  (mlet* %store-monad ((os-drv    (operating-system-derivation os))
+                       (os-dir -> (derivation->output-path os-drv))
+                       (build-gid (operating-system-build-gid os))
+                       (profile   (operating-system-profile-directory os)))
+    (return `((directory "/nix/store" 0 ,(or build-gid 0))
+              (directory "/etc")
+              (directory "/var/log")                     ; for dmd
+              (directory "/var/run/nscd")
+              (directory "/var/nix/gcroots")
+              ("/var/nix/gcroots/system" -> ,os-dir)
+              (directory "/run")
+              ("/run/current-system" -> ,profile)
+              (directory "/bin")
+              ("/bin/sh" -> "/run/current-system/bin/bash")
+              (directory "/tmp")
+              (directory "/var/nix/profiles/per-user/root" 0 0)
+
+              (directory "/root" 0 0)             ; an exception
+              ,@(append-map user-directories
+                            (operating-system-users os))))))
+
+(define* (system-qemu-image os
                             #:key (disk-image-size (* 900 (expt 2 20))))
   "Return the derivation of a QEMU image of DISK-IMAGE-SIZE bytes of the GNU
 system as described by OS."
@@ -445,29 +467,78 @@ system as described by OS."
       ((os-drv      (operating-system-derivation os))
        (os-dir   -> (derivation->output-path os-drv))
        (grub.cfg -> (string-append os-dir "/grub.cfg"))
-       (build-user-gid (anym %store-monad         ; XXX
-                             (lambda (service)
-                               (and (equal? '(guix-daemon)
-                                            (service-provision service))
-                                    (match (service-user-groups service)
-                                      ((group)
-                                       (user-group-id group)))))
-                             (operating-system-services os)))
-       (populate -> `((directory "/nix/store" 0 ,build-user-gid)
-                      (directory "/etc")
-                      (directory "/var/log")      ; for dmd
-                      (directory "/var/run/nscd")
-                      (directory "/var/nix/gcroots")
-                      ("/var/nix/gcroots/system" -> ,os-dir)
-                      (directory "/tmp")
-                      (directory "/var/nix/profiles/per-user/root" 0 0)
-                      (directory "/var/nix/profiles/per-user/guest"
-                                 1000 100)
-                      (directory "/home/guest" 1000 100))))
+       (populate    (operating-system-default-contents os)))
     (qemu-image  #:grub-configuration grub.cfg
                  #:populate populate
                  #:disk-image-size disk-image-size
                  #:initialize-store? #t
                  #:inputs-to-copy `(("system" ,os-drv)))))
 
+(define* (system-qemu-image/shared-store
+          os
+          #:key (disk-image-size (* 15 (expt 2 20))))
+  "Return a derivation that builds a QEMU image of OS that shares its store
+with the host."
+  (mlet* %store-monad
+      ((os-drv      (operating-system-derivation os))
+       (os-dir   -> (derivation->output-path os-drv))
+       (grub.cfg -> (string-append os-dir "/grub.cfg"))
+       (populate    (operating-system-default-contents os)))
+    ;; TODO: Initialize the database so Guix can be used in the guest.
+    (qemu-image #:grub-configuration grub.cfg
+                #:populate populate
+                #:disk-image-size disk-image-size)))
+
+(define* (system-qemu-image/shared-store-script
+          os
+          #:key
+          (qemu (package (inherit qemu)
+                  ;; FIXME/TODO: Use 9p instead of this hack.
+                  (source (package-source qemu/smb-shares))))
+          (graphic? #t))
+  "Return a derivation that builds a script to run a virtual machine image of
+OS that shares its store with the host."
+  (let* ((initrd (qemu-initrd #:mounts `((cifs "/store" ,(%store-prefix)))
+                              #:volatile-root? #t))
+         (os     (operating-system (inherit os) (initrd initrd))))
+    (define builder
+      (mlet %store-monad ((image  (system-qemu-image/shared-store os))
+                          (qemu   (package-file qemu
+                                                "bin/qemu-system-x86_64"))
+                          (bash   (package-file bash "bin/sh"))
+                          (kernel (package-file (operating-system-kernel os)
+                                                "bzImage"))
+                          (initrd initrd)
+                          (os-drv (operating-system-derivation os)))
+        (return `(let ((out (assoc-ref %outputs "out")))
+                   (call-with-output-file out
+                     (lambda (port)
+                       (display
+                        (string-append "#!" ,bash "
+# TODO: -virtfs local,path=XXX,security_model=none,mount_tag=store
+exec " ,qemu " -enable-kvm -no-reboot -net nic,model=virtio \
+  -net user,smb=$PWD \
+  -kernel " ,kernel " -initrd "
+  ,(string-append (derivation->output-path initrd) "/initrd") " \
+-append \"" ,(if graphic? "" "console=ttyS0 ")
+"--load=" ,(derivation->output-path os-drv) "/boot --root=/dev/vda1\" \
+  -drive file=" ,(derivation->output-path image)
+  ",if=virtio,cache=writeback,werror=report,readonly\n")
+                        port)))
+                   (chmod out #o555)
+                   #t))))
+
+    (mlet %store-monad ((image   (system-qemu-image/shared-store os))
+                        (initrd  initrd)
+                        (qemu    (package->derivation qemu))
+                        (bash    (package->derivation bash))
+                        (os      (operating-system-derivation os))
+                        (builder builder))
+      (derivation-expression "run-vm.sh" builder
+                             #:inputs `(("qemu" ,qemu)
+                                        ("image" ,image)
+                                        ("bash" ,bash)
+                                        ("initrd" ,initrd)
+                                        ("os" ,os))))))
+
 ;;; vm.scm ends here