Merge branch 'master' into core-updates

11 files changed, 363 insertions, 76 deletions

diff --git a/gnu/packages/fontutils.scm b/gnu/packages/fontutils.scm
index 8b5e9c582a..ac0dbdf9d5 100644
--- a/gnu/packages/fontutils.scm
+++ b/gnu/packages/fontutils.scm
@@ -19,6 +19,7 @@
 (define-module (gnu packages fontutils)
   #:use-module (gnu packages)
   #:use-module (gnu packages compression)
+  #:use-module (gnu packages ghostscript)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages xml)
   #:use-module ((guix licenses) #:renamer (symbol-prefix-proc 'license:))
@@ -75,11 +76,16 @@ anti-aliased glyph bitmap generation with 256 gray levels.")
    (build-system gnu-build-system)
    (inputs `(("expat" ,expat)
              ("freetype" ,freetype)
+             ("gs-fonts" ,gs-fonts)
              ("pkg-config" ,pkg-config)))
    (arguments
      `(#:configure-flags
-        ;; point to user profile instead of /usr/share/fonts in /etc/fonts.conf
-        `("--with-default-fonts=~/.guix-profile/share/fonts")))
+               ;; point to user profile instead of /usr/share/fonts in /etc/fonts.conf
+        (list "--with-default-fonts=~/.guix-profile/share/fonts"
+              ;; register gs-fonts
+              (string-append "--with-add-fonts="
+                             (assoc-ref %build-inputs "gs-fonts")
+                             "/share/fonts"))))
    (synopsis "Fontconfig, a library for configuring and customising font access.")
    (description
     "Fontconfig can discover new fonts when installed automatically;
diff --git a/gnu/packages/gnupg.scm b/gnu/packages/gnupg.scm
index 7c0f50900a..c098db3315 100644
--- a/gnu/packages/gnupg.scm
+++ b/gnu/packages/gnupg.scm
@@ -57,14 +57,14 @@ Daemon and possibly more in the future.")
 (define-public libgcrypt
   (package
     (name "libgcrypt")
-    (version "1.5.2")
+    (version "1.5.3")
     (source (origin
              (method url-fetch)
              (uri (string-append "mirror://gnupg/libgcrypt/libgcrypt-"
                                  version ".tar.bz2"))
              (sha256
               (base32
-               "0gwnzqd64cpwdmk93nll54nidsr74jpimxzj4p4z7502ylwl66p4"))))
+               "1lar8y3lh61zl5flljpz540d78g99h4d5idfwrfw8lm3gm737xdw"))))
     (build-system gnu-build-system)
     (propagated-inputs
      `(("libgpg-error" ,libgpg-error)))
@@ -106,7 +106,7 @@ provided.")
 (define-public libksba
   (package
     (name "libksba")
-    (version "1.2.0")
+    (version "1.3.0")
     (source
      (origin
       (method url-fetch)
@@ -115,7 +115,7 @@ provided.")
             version ".tar.bz2"))
       (sha256
        (base32
-        "0jwk7hm3x3g4hd7l12z3d79dy7359x7lc88dq6z7q0ixn1jwxbq9"))))
+        "0w8rfb6yhcwkwzvjafrashcygy4hd9xwwmvlnkfd1m2h0paywqas"))))
     (build-system gnu-build-system)
     (propagated-inputs
      `(("libgpg-error" ,libgpg-error)))
@@ -131,7 +131,7 @@ specifications are building blocks of S/MIME and TLS.")
 (define-public gnupg
   (package
     (name "gnupg")
-    (version "2.0.20")
+    (version "2.0.21")
     (source
      (origin
       (method url-fetch)
@@ -139,12 +139,10 @@ specifications are building blocks of S/MIME and TLS.")
                           ".tar.bz2"))
       (sha256
        (base32
-        "16mp0j5inrcqcb3fxbn0b3aamascy3n923wiy0y8marc0rzrp53f"))))
+        "1xgf1q1phdawk6y66haaqcvfnlsqk12jmjin1m2d5x6fqw18kpq0"))))
     (build-system gnu-build-system)
     (inputs
-     `(;; TODO: Add missing optional dep libusb.
-;;        ("libusb" ,libusb)
-       ("bzip2" ,guix:bzip2)
+     `(("bzip2" ,guix:bzip2)
        ("curl" ,curl)
        ("libassuan" ,libassuan)
        ("libgcrypt" ,libgcrypt)
diff --git a/gnu/packages/mail.scm b/gnu/packages/mail.scm
index b8ddcd71e1..a6236e7698 100644
--- a/gnu/packages/mail.scm
+++ b/gnu/packages/mail.scm
@@ -19,6 +19,7 @@
 (define-module (gnu packages mail)
   #:use-module (gnu packages)
   #:use-module (gnu packages autotools)
+  #:use-module (gnu packages cyrus-sasl)
   #:use-module (gnu packages dejagnu)
   #:use-module (gnu packages gdbm)
   #:use-module (gnu packages gnutls)
@@ -154,7 +155,8 @@ aliasing facilities to work just as they would on normal mail.")
                "1864cwz240gh0zy56fb47qqzwyf6ghg01037rb4p2kqgimpg6h91"))))
     (build-system gnu-build-system)
     (inputs
-     `(("ncurses" ,ncurses)
+     `(("cyrus-sasl" ,cyrus-sasl)
+       ("ncurses" ,ncurses)
        ("openssl" ,openssl)
        ("perl" ,perl)))
     (arguments
@@ -162,6 +164,7 @@ aliasing facilities to work just as they would on normal mail.")
                            "--enable-imap"
                            "--enable-pop"
                            "--with-ssl"
+                           "--with-sasl"
                            ;; so that mutt does not check whether the path
                            ;; exists, which it does not in the chroot
                            "--with-mailpath=/var/mail")))
diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm
index 75354122b5..c72d6074ab 100644
--- a/gnu/packages/maths.scm
+++ b/gnu/packages/maths.scm
@@ -108,7 +108,7 @@ extensive test suite.")
 (define-public pspp
   (package
     (name "pspp")
-    (version "0.8.0a")
+    (version "0.8.1")
     (source
      (origin
       (method url-fetch)
@@ -116,7 +116,7 @@ extensive test suite.")
                           version ".tar.gz"))
       (sha256
        (base32
-        "1pgkb3z8b4wk4gymnafclhkrqq7n05wq83mra3v53jdl6bnllmyq"))))
+        "0qhxsdbwxd3cn1shc13wxvx2lg32lp4z6sz24kv3jz7p5xfi8j7x"))))
     (build-system gnu-build-system)
     (inputs
      `(("gettext" ,gnu:gettext)
diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm
index e4eb082230..ccd15cef6f 100644
--- a/gnu/packages/package-management.scm
+++ b/gnu/packages/package-management.scm
@@ -22,7 +22,7 @@
   #:use-module (guix build-system gnu)
   #:use-module ((guix licenses) #:select (gpl3+))
   #:use-module (gnu packages guile)
-  #:use-module ((gnu packages compression) #:select (bzip2))
+  #:use-module ((gnu packages compression) #:select (bzip2 gzip))
   #:use-module (gnu packages gnupg)
   #:use-module (gnu packages sqlite)
   #:use-module (gnu packages pkg-config))
@@ -41,6 +41,7 @@
     (build-system gnu-build-system)
     (arguments
      `(#:configure-flags (list
+                          "--localstatedir=/var"
                           (string-append "--with-libgcrypt-prefix="
                                          (assoc-ref %build-inputs
                                                     "libgcrypt")))
@@ -70,6 +71,8 @@
                                 "/20130105/guile-2.0.7.tar.xz"))
                           (sha256 hash)))))
        `(("bzip2" ,bzip2)
+         ("gzip" ,gzip)
+
          ("sqlite" ,sqlite)
          ("libgcrypt" ,libgcrypt)
          ("guile" ,guile-2.0)
@@ -100,3 +103,20 @@ A user-land free software distribution for GNU/Linux comes as part of Guix.
 
 Guix is based on the Nix package manager.")
     (license gpl3+)))
+
+(define-public guix-0.4
+  ;; XXX: Hack to allow the use of a 0.4ish tarball.  This assumes that you
+  ;; have run 'make dist' in your build tree.  Remove when 0.4 is out.
+  (let* ((builddir (dirname
+                    (canonicalize-path
+                     (dirname (search-path %load-path
+                                           "guix/config.scm")))))
+         (tarball  (string-append builddir "/guix-0.4.tar.gz")))
+    (package (inherit guix)
+      (version "0.4rc")
+      (source (if (file-exists? tarball)
+                  tarball
+                  (begin
+                    (format (current-error-port)
+                            "warning: 'guix-0.4.tar.gz' not found~%")
+                    (package-source guix)))))))
diff --git a/gnu/packages/scheme.scm b/gnu/packages/scheme.scm
index 43853fa08c..b7df902136 100644
--- a/gnu/packages/scheme.scm
+++ b/gnu/packages/scheme.scm
@@ -32,6 +32,7 @@
   #:use-module (gnu packages avahi)
   #:use-module (gnu packages libphidget)
   #:use-module (gnu packages glib)
+  #:use-module (gnu packages gtk)
   #:use-module (gnu packages libffi)
   #:use-module (gnu packages libjpeg)
   #:use-module ((gnu packages gtk) #:select (cairo pango))
@@ -358,12 +359,15 @@ implementation techniques and as an expository tool.")
      '(#:phases
        (let* ((gui-libs
                (lambda (inputs)
-                 ;; FIXME: Add GTK+ and GDK for DrRacket.
-                 (let ((glib     (string-append (assoc-ref inputs "glib") "/lib"))
-                       (cairo    (string-append (assoc-ref inputs "cairo") "/lib"))
-                       (pango    (string-append (assoc-ref inputs "pango") "/lib"))
-                       (libjpeg  (string-append (assoc-ref inputs "libjpeg") "/lib")))
-                   (list glib cairo pango libjpeg)))))
+                 (define (lib input)
+                   (string-append (assoc-ref inputs input) "/lib"))
+
+                 (list (lib "glib")
+                       (lib "cairo")
+                       (lib "pango")
+                       (lib "libjpeg")
+                       (lib "gtk")
+                       (lib "gdk-pixbuf")))))
          (alist-cons-before
           'configure 'pre-configure
           (lambda* (#:key inputs #:allow-other-keys)
@@ -397,7 +401,9 @@ implementation techniques and as an expository tool.")
               ("glib" ,glib)                      ; for DrRacket
               ("cairo" ,cairo)
               ("pango" ,pango)
-              ("libjpeg" ,libjpeg-8)))
+              ("libjpeg" ,libjpeg-8)
+              ("gdk-pixbuf" ,gdk-pixbuf)
+              ("gtk" ,gtk+)))
     (home-page "http://racket-lang.org")
     (synopsis "Implementation of Scheme and related languages")
     (description
diff --git a/gnu/packages/xorg.scm b/gnu/packages/xorg.scm
index 0659c8d10c..613e2c5f0e 100644
--- a/gnu/packages/xorg.scm
+++ b/gnu/packages/xorg.scm
@@ -29,11 +29,11 @@
   #:use-module ((gnu packages gettext)
                 #:renamer (symbol-prefix-proc 'gnu:))
   #:use-module (gnu packages glib)
+  #:use-module (gnu packages gnupg)
   #:use-module (gnu packages gperf)
   #:use-module (gnu packages libpng)
   #:use-module (gnu packages linux)
   #:use-module (gnu packages m4)
-  #:use-module (gnu packages openssl)
   #:use-module (gnu packages perl)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
@@ -3114,9 +3114,9 @@ tracking.")
     (license license:x11)))
 
 
-(define-public xkbcomp
+(define xkbcomp-intermediate ; used as input for xkeyboard-config
   (package
-    (name "xkbcomp")
+    (name "xkbcomp-intermediate")
     (version "1.2.4")
     (source
       (origin
@@ -3139,6 +3139,18 @@ tracking.")
     (description "X.org provides an implementation of the X Window System")
     (license license:x11)))
 
+(define-public xkbcomp ; using xkeyboard-config as input
+  (package (inherit xkbcomp-intermediate)
+    (name "xkbcomp")
+    (inputs
+      `(,@(package-inputs xkbcomp-intermediate)
+        ("xkeyboard-config" ,xkeyboard-config)))
+    (arguments
+     `(#:configure-flags
+       (list (string-append "--with-xkb-config-root="
+                            (assoc-ref %build-inputs "xkeyboard-config")
+                            "/share/X11/xkb"))))))
+
 
 (define-public xkbevd
   (package
@@ -3212,7 +3224,7 @@ tracking.")
         ("intltool" ,intltool)
         ("libx11" ,libx11)
         ("pkg-config" ,pkg-config)
-        ("xkbcomp" ,xkbcomp)))
+        ("xkbcomp-intermediate" ,xkbcomp-intermediate)))
     (home-page "http://www.x.org/wiki/")
     (synopsis "xorg implementation of the X Window System")
     (description "X.org provides an implementation of the X Window System")
@@ -4262,6 +4274,7 @@ emulation to complete hardware acceleration for modern GPUs.")
         ("dbus" ,dbus)
         ("dmxproto" ,dmxproto)
         ("libdmx" ,libdmx)
+        ("libgcrypt" ,libgcrypt)
         ("libxau" ,libxau)
         ("libxaw" ,libxaw)
         ("libxdmcp" ,libxdmcp)
@@ -4273,7 +4286,6 @@ emulation to complete hardware acceleration for modern GPUs.")
         ("libxt" ,libxt)
         ("libxv" ,libxv)
         ("mesa" ,mesa)
-        ("openssl" ,openssl)
         ("pkg-config" ,pkg-config)
         ("python" ,python-wrapper)
         ("recordproto" ,recordproto)
@@ -4284,10 +4296,30 @@ emulation to complete hardware acceleration for modern GPUs.")
         ("xf86dgaproto" ,xf86dgaproto)
         ("xf86driproto" ,xf86driproto)
         ("xf86vidmodeproto" ,xf86vidmodeproto)
-;;        ("xkbutils" ,xkbutils)
-;;        ("xkeyboard-config" ,xkeyboard-config)
+        ("xkbcomp" ,xkbcomp)
+        ("xkeyboard-config" ,xkeyboard-config)
         ("xtrans" ,xtrans)
         ("zlib" ,zlib)))
+    (arguments
+     `(#:configure-flags
+       (list (string-append "--with-xkb-path="
+                            (assoc-ref %build-inputs "xkeyboard-config")
+                            "/share/X11/xkb")
+             (string-append "--with-xkb-output="
+                            "/tmp") ; FIXME: This is a bit doubtful; where should
+                                    ; the compiled keyboard maps go?
+             (string-append "--with-xkb-bin-directory="
+                            (assoc-ref %build-inputs "xkbcomp")
+                            "/bin"))
+       #:phases
+        (alist-replace
+         'configure
+         (lambda* (#:key outputs #:allow-other-keys #:rest args)
+           (let ((configure (assoc-ref %standard-phases 'configure)))
+             (substitute* (find-files "." "\\.c$")
+               (("/bin/sh") (which "sh")))
+             (apply configure args)))
+         %standard-phases)))
     (home-page "http://www.x.org/wiki/")
     (synopsis "xorg implementation of the X Window System")
     (description "X.org provides an implementation of the X Window System")
diff --git a/gnu/packages/zile.scm b/gnu/packages/zile.scm
index 6e540ccfab..4907031c89 100644
--- a/gnu/packages/zile.scm
+++ b/gnu/packages/zile.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -24,25 +24,37 @@
   #:use-module (gnu packages bdw-gc)
   #:use-module (gnu packages perl)
   #:use-module (gnu packages help2man)
-  #:use-module (gnu packages ncurses))
+  #:use-module (gnu packages ncurses)
+  #:use-module (gnu packages bash))
 
 (define-public zile
   (package
     (name "zile")
     (version "2.4.9")
-    (source
-     (origin
-      (method url-fetch)
-      (uri (string-append "mirror://gnu/zile/zile-"
-                          version ".tar.gz"))
-      (sha256
-       (base32
-        "0j801c28ypm924rw3lqyb6khxyslg6ycrv16wmmwcam0mk3mj6f7"))))
+    (source (origin
+             (method url-fetch)
+             (uri (string-append "mirror://gnu/zile/zile-"
+                                 version ".tar.gz"))
+             (sha256
+              (base32
+               "0j801c28ypm924rw3lqyb6khxyslg6ycrv16wmmwcam0mk3mj6f7"))))
     (build-system gnu-build-system)
+    (arguments
+     '(#:phases (alist-cons-before
+                 'configure 'patch-/bin/sh
+                 (lambda* (#:key inputs #:allow-other-keys)
+                   (let ((bash (assoc-ref inputs "bash")))
+                     ;; Refer to the actual shell.
+                     (substitute* '("lib/spawni.c" "src/funcs.c")
+                       (("/bin/sh")
+                        (string-append bash "/bin/sh")))))
+                 %standard-phases)))
     (inputs
      `(("boehm-gc" ,libgc)
        ("ncurses" ,ncurses)
-       ("perl" ,perl)
+       ("bash" ,bash)))
+    (native-inputs
+     `(("perl" ,perl)
        ("help2man" ,help2man)))
     (home-page "http://www.gnu.org/software/zile/")
     (synopsis "Zile is lossy Emacs, a lightweight Emacs clone")
diff --git a/gnu/system/dmd.scm b/gnu/system/dmd.scm
index 1e8767e357..b248d9f0c5 100644
--- a/gnu/system/dmd.scm
+++ b/gnu/system/dmd.scm
@@ -21,8 +21,12 @@
   #:use-module (guix packages)
   #:use-module (guix derivations)
   #:use-module (guix records)
+  #:use-module ((gnu packages base)
+                #:select (glibc-final))
   #:use-module ((gnu packages system)
                 #:select (mingetty inetutils))
+  #:use-module ((gnu packages package-management)
+                #:select (guix))
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:export (service?
@@ -34,8 +38,13 @@
             service-stop
             service-inputs
 
+            host-name-service
             syslog-service
             mingetty-service
+            nscd-service
+            guix-service
+            static-networking-service
+
             dmd-configuration-file))
 
 ;;; Commentary:
@@ -58,6 +67,14 @@
   (inputs        service-inputs                   ; list of inputs
                  (default '())))
 
+(define (host-name-service store name)
+  "Return a service that sets the host name to NAME."
+  (service
+   (provision '(host-name))
+   (start `(lambda _
+             (sethostname ,name)))
+   (respawn? #f)))
+
 (define (mingetty-service store tty)
   "Return a service to run mingetty on TTY."
   (let* ((mingetty-drv (package-derivation store mingetty))
@@ -65,9 +82,32 @@
                                       "/sbin/mingetty")))
     (service
      (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))
      (inputs `(("mingetty" ,mingetty))))))
 
+(define* (nscd-service store
+                       #:key (glibc glibc-final))
+  "Return a service that runs libc's name service cache daemon (nscd)."
+  (let ((nscd (string-append (package-output store glibc) "/sbin/nscd")))
+    (service
+     (provision '(nscd))
+     (start `(make-forkexec-constructor ,nscd "-f" "/dev/null"))
+
+     ;; XXX: Local copy of 'make-kill-destructor' because the one upstream
+     ;; uses the broken 'opt-lambda' macro.
+     (stop  `(lambda* (#:optional (signal SIGTERM))
+               (lambda (pid . args)
+                 (kill pid signal)
+                 #f)))
+
+     (respawn? #f)
+     (inputs `(("glibc" ,glibc))))))
+
 (define (syslog-service store)
   "Return a service that runs 'syslogd' with reasonable default settings."
 
@@ -104,6 +144,33 @@
      (inputs `(("inetutils" ,inetutils)
                ("syslog.conf" ,syslog.conf))))))
 
+(define* (guix-service store #:key (guix guix))
+  "Return a service that runs the build daemon from GUIX."
+  (let* ((drv    (package-derivation store guix))
+         (daemon (string-append (derivation->output-path drv)
+                                "/bin/guix-daemon")))
+    (service
+     (provision '(guix-daemon))
+     (start `(make-forkexec-constructor ,daemon))
+     (inputs `(("guix" ,guix))))))
+
+(define* (static-networking-service store interface ip
+                                    #:key (inetutils inetutils))
+  "Return a service that starts INTERFACE with address IP."
+
+  ;; 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.
+  (let ((ifconfig (string-append (package-output store inetutils)
+                                 "/bin/ifconfig")))
+    (service
+     (provision '(networking))
+     (start `(make-forkexec-constructor ,ifconfig ,interface ,ip "up"))
+     (stop  `(make-forkexec-constructor ,ifconfig ,interface "down"))
+     (respawn? #f)
+     (inputs `(("inetutils" ,inetutils))))))
+
+
 (define (dmd-configuration-file store services)
   "Return the dmd configuration file for SERVICES."
   (define config
diff --git a/gnu/system/linux.scm b/gnu/system/linux.scm
index b2daa13e06..6aebe159ba 100644
--- a/gnu/system/linux.scm
+++ b/gnu/system/linux.scm
@@ -125,9 +125,10 @@
   (let ((unix (pam-entry
                (control "required")
                (module "pam_unix.so"))))
-    (lambda* (name #:key allow-empty-passwords?)
+    (lambda* (name #:key allow-empty-passwords? motd)
       "Return a standard Unix-style PAM service for NAME.  When
-ALLOW-EMPTY-PASSWORDS? is true, allow empty passwords."
+ALLOW-EMPTY-PASSWORDS? is true, allow empty passwords.  When MOTD is true, it
+should be the name of a file used as the message-of-the-day."
       ;; See <http://www.linux-pam.org/Linux-PAM-html/sag-configuration-example.html>.
       (let ((name* name))
         (pam-service
@@ -140,6 +141,12 @@ ALLOW-EMPTY-PASSWORDS? is true, allow empty passwords."
                           (arguments '("nullok")))
                          unix)))
          (password (list unix))
-         (session (list unix)))))))
+         (session (if motd
+                      (list unix
+                            (pam-entry
+                             (control "optional")
+                             (module "pam_motd.so")
+                             (arguments (list (string-append "motd=" motd)))))
+                      (list unix))))))))
 
 ;;; linux.scm ends here
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index df55f7c94e..0ed805510a 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -23,6 +23,8 @@
   #:use-module (guix packages)
   #:use-module ((gnu packages base) #:select (%final-inputs
                                               guile-final
+                                              gcc-final
+                                              glibc-final
                                               coreutils))
   #:use-module (gnu packages guile)
   #:use-module (gnu packages bash)
@@ -31,6 +33,7 @@
   #: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))
   #:use-module (gnu packages system)
@@ -91,6 +94,10 @@ made available under the /xchg CIFS share."
            `(,input . ,(package-output store package "out" system)))
           ((input (? package? package) sub-drv)
            `(,input . ,(package-output store package sub-drv system)))
+          ((input (? derivation? drv))
+           `(,input . ,(derivation->output-path drv)))
+          ((input (? derivation? drv) sub-drv)
+           `(,input . ,(derivation->output-path drv sub-drv)))
           ((input (and (? string?) (? store-path?) file))
            `(,input . ,file)))
          inputs))
@@ -177,7 +184,8 @@ made available under the /xchg CIFS share."
                                              `(,name ,(->drv package)
                                                      ,@sub-drv))
                                             ((name (? string? file))
-                                             `(,name ,file)))
+                                             `(,name ,file))
+                                            (tuple tuple))
                                            inputs))
                                   #:env-vars env-vars
                                   #:modules (delete-duplicates
@@ -191,6 +199,7 @@ made available under the /xchg CIFS share."
                      (system (%current-system))
                      (disk-image-size (* 100 (expt 2 20)))
                      grub-configuration
+                     (initialize-store? #f)
                      (populate #f)
                      (inputs '())
                      (inputs-to-copy '()))
@@ -199,11 +208,13 @@ disk image, with a GRUB installation that uses GRUB-CONFIGURATION as its
 configuration file.
 
 INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied
-into the image being built.
+into the image being built.  When INITIALIZE-STORE? is true, initialize the
+store database in the image so that Guix can be used in the image.
 
-When POPULATE is true, it must be the store file name of a Guile script to run
-in the disk image partition once it has been populated with INPUTS-TO-COPY.
-It can be used to provide additional files, such as /etc files."
+POPULATE is a list of directives stating directories or symlinks to be created
+in the disk image partition.  It is evaluated once the image has been
+populated with INPUTS-TO-COPY.  It can be used to provide additional files,
+such as /etc files."
   (define input->name+derivation
     (match-lambda
      ((name (? package? package))
@@ -213,6 +224,10 @@ It can be used to provide additional files, such as /etc files."
       `(,name . ,(derivation->output-path
                   (package-derivation store package system)
                   sub-drv)))
+     ((name (? derivation? drv))
+      `(,name . ,(derivation->output-path drv)))
+     ((name (? derivation? drv) sub-drv)
+      `(,name . ,(derivation->output-path drv sub-drv)))
      ((input (and (? string?) (? store-path?) file))
       `(,input . ,file))))
 
@@ -298,6 +313,36 @@ It can be used to provide additional files, such as /etc files."
                       ;; Populate /dev.
                       (make-essential-device-nodes #:root "/fs")
 
+                      ;; Optionally, register the inputs in the image's store.
+                      (let* ((guix     (assoc-ref %build-inputs "guix"))
+                             (register (string-append guix
+                                                      "/sbin/guix-register")))
+                        ,@(if initialize-store?
+                              (match inputs-to-copy
+                                (((graph-files . _) ...)
+                                 (map (lambda (closure)
+                                        `(system* register "--prefix" "/fs"
+                                                  ,(string-append "/xchg/"
+                                                                  closure)))
+                                      graph-files)))
+                              '(#f)))
+
+                      ;; Evaluate the POPULATE directives.
+                      ,@(let loop ((directives populate)
+                                   (statements '()))
+                          (match directives
+                            (()
+                             (reverse statements))
+                            ((('directory name) rest ...)
+                             (loop rest
+                                   (cons `(mkdir-p ,(string-append "/fs" name))
+                                         statements)))
+                            (((new '-> old) rest ...)
+                             (loop rest
+                                   (cons `(symlink ,old
+                                                   ,(string-append "/fs" new))
+                                         statements)))))
+
                       (and=> (assoc-ref %build-inputs "populate")
                              (lambda (populate)
                                (chdir "/fs")
@@ -337,8 +382,8 @@ It can be used to provide additional files, such as /etc files."
               ("gawk" ,(car (assoc-ref %final-inputs "gawk")))
               ("util-linux" ,util-linux)
 
-              ,@(if populate
-                    `(("populate" ,populate))
+              ,@(if initialize-store?
+                    `(("guix" ,guix-0.4))
                     '())
 
               ,@inputs-to-copy)
@@ -353,19 +398,73 @@ It can be used to provide additional files, such as /etc files."
 ;;; Stand-alone VM image.
 ;;;
 
+(define* (union store inputs
+                #:key (guile (%guile-for-build)) (system (%current-system))
+                (name "union"))
+  "Return a derivation that builds the union of INPUTS.  INPUTS is a list of
+input tuples."
+  (define builder
+    `(begin
+       (use-modules (guix build union))
+
+       (setvbuf (current-output-port) _IOLBF)
+       (setvbuf (current-error-port) _IOLBF)
+
+       (let ((output (assoc-ref %outputs "out"))
+             (inputs (map cdr %build-inputs)))
+         (format #t "building union `~a' with ~a packages...~%"
+                 output (length inputs))
+         (union-build output inputs))))
+
+  (build-expression->derivation store name system builder
+                                (map (match-lambda
+                                      ((name (? package? p))
+                                       `(,name ,(package-derivation store p
+                                                                    system)))
+                                      ((name (? package? p) output)
+                                       `(,name ,(package-derivation store p
+                                                                    system)
+                                               ,output))
+                                      (x x))
+                                     inputs)
+                                #:modules '((guix build union))
+                                #:guile-for-build guile))
+
 (define (system-qemu-image store)
   "Return the derivation of a QEMU image of the GNU system."
+  (define motd
+    (add-text-to-store store "motd" "
+Happy birthday, GNU!                                http://www.gnu.org/gnu30
+
+"))
+
   (define %pam-services
     ;; Services known to PAM.
     (list %pam-other-services
-          (unix-pam-service "login" #:allow-empty-passwords? #t)))
+          (unix-pam-service "login"
+                            #:allow-empty-passwords? #t
+                            #:motd motd)))
 
   (define %dmd-services
     ;; Services run by dmd.
-    (list (mingetty-service store "tty1")
+    (list (host-name-service store "gnu")
+          (mingetty-service store "tty1")
           (mingetty-service store "tty2")
           (mingetty-service store "tty3")
-          (syslog-service store)))
+          (mingetty-service store "tty4")
+          (mingetty-service store "tty5")
+          (mingetty-service store "tty6")
+          (syslog-service store)
+          (guix-service store #:guix guix-0.4)
+          (nscd-service store)
+
+          ;; QEMU networking settings.
+          (static-networking-service store "eth0" "10.0.2.10")))
+
+  (define resolv.conf
+    ;; Name resolution for default QEMU settings.
+    (add-text-to-store store "resolv.conf"
+                       "nameserver 10.0.2.3\n"))
 
   (parameterize ((%guile-for-build (package-derivation store guile-final)))
     (let* ((bash-drv  (package-derivation store bash))
@@ -383,20 +482,53 @@ It can be used to provide additional files, such as /etc files."
                                          "root:x:0:\n"))
            (pam.d-drv (pam-services->directory store %pam-services))
            (pam.d     (derivation->output-path pam.d-drv))
-           (populate
-            (add-text-to-store store "populate-qemu-image"
-                               (object->string
-                                `(begin
-                                   (mkdir-p "etc")
-                                   (mkdir-p "var/log") ; for dmd
-                                   (symlink ,shadow "etc/shadow")
-                                   (symlink ,passwd "etc/passwd")
-                                   (symlink ,group "etc/group")
-                                   (symlink "/dev/null"
-                                            "etc/login.defs")
-                                   (symlink ,pam.d "etc/pam.d")
-                                   (mkdir-p "var/run")))
-                               (list passwd)))
+
+           (packages `(("coreutils" ,coreutils)
+                       ("bash" ,bash)
+                       ("guile" ,guile-2.0)
+                       ("dmd" ,dmd)
+                       ("gcc" ,gcc-final)
+                       ("libc" ,glibc-final)
+                       ("inetutils" ,inetutils)
+                       ("guix" ,guix-0.4)))
+
+           ;; TODO: Replace with a real profile with a manifest.
+           ;; TODO: Generate bashrc from packages' search-paths.
+           (profile-drv (union store packages
+                               #:name "default-profile"))
+           (profile  (derivation->output-path profile-drv))
+           (bashrc   (add-text-to-store store "bashrc"
+                                        (string-append "
+export PS1='\\u@\\h\\$ '
+export PATH=$HOME/.guix-profile/bin:" profile "/bin:" profile "/sbin
+export CPATH=$HOME/.guix-profile/include:" profile "/include
+export LIBRARY_PATH=$HOME/.guix-profile/lib:" profile "/lib
+alias ls='ls -p --color'
+alias ll='ls -l'
+")))
+
+           (issue    (add-text-to-store store "issue" "
+This is an alpha preview of the GNU system.  Welcome.
+
+This image features the GNU Guix package manager, which was used to
+build it (http://www.gnu.org/software/guix/).  The init system is
+GNU dmd (http://www.gnu.org/software/dmd/).
+
+You can log in as 'root' with no password.
+"))
+
+           (populate `((directory "/etc")
+                       (directory "/var/log")     ; for dmd
+                       (directory "/var/run/nscd")
+                       ("/etc/shadow" -> ,shadow)
+                       ("/etc/passwd" -> ,passwd)
+                       ("/etc/login.defs" -> "/dev/null")
+                       ("/etc/pam.d" -> ,pam.d)
+                       ("/etc/resolv.conf" -> ,resolv.conf)
+                       ("/etc/profile" -> ,bashrc)
+                       ("/etc/issue" -> ,issue)
+                       (directory "/var/nix/gcroots")
+                       ("/var/nix/gcroots/default-profile" -> ,profile)))
            (out     (derivation->output-path
                      (package-derivation store mingetty)))
            (boot    (add-text-to-store store "boot"
@@ -405,32 +537,36 @@ It can be used to provide additional files, such as /etc files."
                                                 "--config" ,dmd-conf))
                                        (list out)))
            (entries  (list (menu-entry
-                            (label "Boot-to-Guile! (GNU System technology preview)")
+                            (label (string-append
+                                    "GNU System with Linux-Libre "
+                                    (package-version linux-libre)
+                                    " (technology preview)"))
                             (linux linux-libre)
                             (linux-arguments `("--root=/dev/vda1"
                                                ,(string-append "--load=" boot)))
                             (initrd gnu-system-initrd))))
            (grub.cfg (grub-configuration-file store entries)))
-      (build-derivations store (list pam.d-drv))
       (qemu-image store
                   #:grub-configuration grub.cfg
                   #:populate populate
-                  #:disk-image-size (* 400 (expt 2 20))
+                  #:disk-image-size (* 500 (expt 2 20))
+                  #:initialize-store? #t
                   #:inputs-to-copy `(("boot" ,boot)
                                      ("linux" ,linux-libre)
                                      ("initrd" ,gnu-system-initrd)
-                                     ("coreutils" ,coreutils)
-                                     ("bash" ,bash)
-                                     ("guile" ,guile-2.0)
-                                     ("mingetty" ,mingetty)
-                                     ("dmd" ,dmd)
+                                     ("pam.d" ,pam.d-drv)
+                                     ("profile" ,profile-drv)
 
                                      ;; Configuration.
                                      ("dmd.conf" ,dmd-conf)
-                                     ("etc-pam.d" ,pam.d)
+                                     ("etc-pam.d" ,pam.d-drv)
                                      ("etc-passwd" ,passwd)
                                      ("etc-shadow" ,shadow)
                                      ("etc-group" ,group)
+                                     ("etc-resolv.conf" ,resolv.conf)
+                                     ("etc-bashrc" ,bashrc)
+                                     ("etc-issue" ,issue)
+                                     ("etc-motd" ,motd)
                                      ,@(append-map service-inputs
                                                    %dmd-services))))))