gnu: vm: Rewrite helper functions as monadic functions.

* gnu/system/dmd.scm (host-name-service, nscd-service, mingetty-service,
  syslog-service, guix-service, static-networking-service): Rewrite as
  monadic functions.
  (dmd-configuration-file): Use 'text-file' instead of
  'add-text-to-store'.
* gnu/system/grub.scm (grub-configuration-file): Rewrite as a monadic
  function.
* gnu/system/linux.scm (pam-services->directory): Likewise.
* gnu/system/shadow.scm (group-file, passwd-file, guix-build-accounts):
  Likewise.
* gnu/system/vm.scm (expression->derivation-in-linux-vm, qemu-image,
  union, system-qemu-image): Likewise.

5 files changed, 560 insertions, 558 deletions

diff --git a/gnu/system/dmd.scm b/gnu/system/dmd.scm
index 4d3b4b31f0..946b6a7937 100644
--- a/gnu/system/dmd.scm
+++ b/gnu/system/dmd.scm
@@ -31,6 +31,7 @@
                 #:select (net-tools))
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
+  #:use-module (guix monads)
   #:export (service?
             service
             service-provision
@@ -69,53 +70,51 @@
   (inputs        service-inputs                   ; list of inputs
                  (default '())))
 
-(define (host-name-service store name)
+(define (host-name-service 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)
+  (with-monad %store-monad
+    (return (service
+             (provision '(host-name))
+             (start `(lambda _
+                       (sethostname ,name)))
+             (respawn? #f)))))
+
+(define (mingetty-service tty)
   "Return a service to run mingetty on TTY."
-  (let* ((mingetty-drv (package-derivation store mingetty))
-         (mingetty-bin (string-append (derivation->output-path mingetty-drv)
-                                      "/sbin/mingetty")))
-    (service
-     (provision (list (symbol-append 'term- (string->symbol tty))))
+  (mlet %store-monad ((mingetty-bin (package-file mingetty "sbin/mingetty")))
+    (return
+     (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))
+      ;; 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))))))
+      (start `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty))
+      (inputs `(("mingetty" ,mingetty)))))))
 
-(define* (nscd-service store
-                       #:key (glibc glibc-final))
+(define* (nscd-service #: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)
+  (mlet %store-monad ((nscd (package-file glibc "sbin/nscd")))
+    (return (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)
   "Return a service that runs 'syslogd' with reasonable default settings."
 
-  (define syslog.conf
-    ;; Snippet adapted from the GNU inetutils manual.
-    (add-text-to-store store "syslog.conf" "
+  ;; 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.
@@ -134,31 +133,30 @@
 
      # Log all the mail messages in one place.
      mail.*                                  /var/log/maillog
-"))
-
-  (let* ((inetutils-drv (package-derivation store inetutils))
-         (syslogd       (string-append (derivation->output-path inetutils-drv)
-                                       "/libexec/syslogd")))
-    (service
-     (provision '(syslogd))
-     (start `(make-forkexec-constructor ,syslogd
-                                        "--rcfile" ,syslog.conf))
-     (inputs `(("inetutils" ,inetutils)
-               ("syslog.conf" ,syslog.conf))))))
-
-(define* (guix-service store #:key (guix guix) (builder-group "guixbuild"))
+")
+
+  (mlet %store-monad
+      ((syslog.conf (text-file "syslog.conf" contents))
+       (syslogd     (package-file inetutils "libexec/syslogd")))
+    (return
+     (service
+      (provision '(syslogd))
+      (start `(make-forkexec-constructor ,syslogd
+                                         "--rcfile" ,syslog.conf))
+      (inputs `(("inetutils" ,inetutils)
+                ("syslog.conf" ,syslog.conf)))))))
+
+(define* (guix-service #:key (guix guix) (builder-group "guixbuild"))
   "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
-                                        "--build-users-group"
-                                        ,builder-group))
-     (inputs `(("guix" ,guix))))))
-
-(define* (static-networking-service store interface ip
+  (mlet %store-monad ((daemon (package-file guix "bin/guix-daemon")))
+    (return (service
+             (provision '(guix-daemon))
+             (start `(make-forkexec-constructor ,daemon
+                                                "--build-users-group"
+                                                ,builder-group))
+             (inputs `(("guix" ,guix)))))))
+
+(define* (static-networking-service interface ip
                                     #:key
                                     gateway
                                     (inetutils inetutils)
@@ -169,31 +167,30 @@ 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.
-  (let ((ifconfig (string-append (package-output store inetutils)
-                                 "/bin/ifconfig"))
-        (route    (string-append (package-output store net-tools)
-                                 "/sbin/route")))
-    (service
-     (provision '(networking))
-     (start `(lambda _
-               (and (zero? (system* ,ifconfig ,interface ,ip "up"))
-                    ,(if gateway
-                         `(begin
-                            (sleep 3)             ; XXX
-                            (zero? (system* ,route "add" "-net" "default"
-                                            "gw" ,gateway)))
-                         #t))))
-     (stop  `(lambda _
-               (system* ,ifconfig ,interface "down")
-               (system* ,route "del" "-net" "default")))
-     (respawn? #f)
-     (inputs `(("inetutils" ,inetutils)
-               ,@(if gateway
-                     `(("net-tools" ,net-tools))
-                     '()))))))
+  (mlet %store-monad ((ifconfig (package-file inetutils "bin/ifconfig"))
+                      (route    (package-file net-tools "sbin/route")))
+    (return
+     (service
+      (provision '(networking))
+      (start `(lambda _
+                (and (zero? (system* ,ifconfig ,interface ,ip "up"))
+                     ,(if gateway
+                          `(begin
+                             (sleep 3)            ; XXX
+                             (zero? (system* ,route "add" "-net" "default"
+                                             "gw" ,gateway)))
+                          #t))))
+      (stop  `(lambda _
+                (system* ,ifconfig ,interface "down")
+                (system* ,route "del" "-net" "default")))
+      (respawn? #f)
+      (inputs `(("inetutils" ,inetutils)
+                ,@(if gateway
+                      `(("net-tools" ,net-tools))
+                      '())))))))
 
 
-(define (dmd-configuration-file store services)
+(define (dmd-configuration-file services)
   "Return the dmd configuration file for SERVICES."
   (define config
     `(begin
@@ -209,7 +206,6 @@ true, it must be a string specifying the default network gateway."
                services))
        (for-each start ',(append-map service-provision services))))
 
-  (add-text-to-store store "dmd.conf"
-                     (object->string config)))
+  (text-file "dmd.conf" (object->string config)))
 
 ;;; dmd.scm ends here
diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm
index b2438b9c5b..abc220b532 100644
--- a/gnu/system/grub.scm
+++ b/gnu/system/grub.scm
@@ -21,6 +21,7 @@
   #:use-module (guix packages)
   #:use-module (guix derivations)
   #:use-module (guix records)
+  #:use-module (guix monads)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:export (menu-entry
@@ -42,43 +43,45 @@
                    (default '()))
   (initrd          menu-entry-initrd))
 
-(define* (grub-configuration-file store entries
+(define* (grub-configuration-file entries
                                   #:key (default-entry 1) (timeout 5)
                                   (system (%current-system)))
-  "Return the GRUB configuration file in STORE for ENTRIES, a list of
+  "Return the GRUB configuration file for ENTRIES, a list of
 <menu-entry> objects, defaulting to DEFAULT-ENTRY and with the given TIMEOUT."
-  (define prologue
+  (define (prologue kernel)
     (format #f "
 set default=~a
 set timeout=~a
 search.file ~a~%"
-            default-entry timeout
-            (any (match-lambda
-                  (($ <menu-entry> _ linux)
-                   (let* ((drv (package-derivation store linux system))
-                          (out (derivation->output-path drv)))
-                     (string-append out "/bzImage"))))
-                 entries)))
+            default-entry timeout kernel))
+
+  (define (bzImage)
+    (anym %store-monad
+          (match-lambda
+           (($ <menu-entry> _ linux)
+            (package-file linux "bzImage"
+                          #:system system)))
+          entries))
 
   (define entry->text
     (match-lambda
      (($ <menu-entry> label linux arguments initrd)
-      (let ((linux-drv  (package-derivation store linux system))
-            (initrd-drv (package-derivation store initrd system)))
+      (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.
-        (format #f "menuentry ~s {
-  linux ~a/bzImage ~a
-  initrd ~a/initrd
+        (return (format #f "menuentry ~s {
+  linux ~a ~a
+  initrd ~a
 }~%"
-                label
-                (derivation->output-path linux-drv)
-                (string-join arguments)
-                (derivation->output-path initrd-drv))))))
+                        label
+                        linux (string-join arguments) initrd))))))
 
-  (add-text-to-store store "grub.cfg"
-                     (string-append prologue
-                                    (string-concatenate
-                                     (map entry->text entries)))
-                     '()))
+  (mlet %store-monad ((kernel (bzImage))
+                      (body   (mapm %store-monad entry->text entries)))
+    (text-file "grub.cfg"
+               (string-append (prologue kernel)
+                              (string-concatenate body)))))
 
 ;;; grub.scm ends here
diff --git a/gnu/system/linux.scm b/gnu/system/linux.scm
index 6aebe159ba..eb3e133044 100644
--- a/gnu/system/linux.scm
+++ b/gnu/system/linux.scm
@@ -20,6 +20,7 @@
   #:use-module (guix store)
   #:use-module (guix records)
   #:use-module (guix derivations)
+  #:use-module (guix monads)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
@@ -81,17 +82,20 @@
               (map (cut entry->string "password" <>) password)
               (map (cut entry->string "session" <>) session))))))
 
-(define (pam-services->directory store services)
+(define (pam-services->directory services)
   "Return the derivation to build the configuration directory to be used as
 /etc/pam.d for SERVICES."
-  (let ((names (map pam-service-name services))
-        (files (map (match-lambda
+  (mlet %store-monad
+      ((names -> (map pam-service-name services))
+       (files (mapm %store-monad
+                    (match-lambda
                      ((and service ($ <pam-service> name))
                       (let ((config (pam-service->configuration service)))
-                        (add-text-to-store store
-                                           (string-append name ".pam")
-                                           config '()))))
-                    services)))
+                        (text-file (string-append name ".pam") config))))
+
+                    ;; XXX: Eventually, SERVICES may be a list of monadic
+                    ;; values instead of plain values.
+                    (map return services))))
     (define builder
       '(begin
          (use-modules (ice-9 match))
@@ -104,9 +108,7 @@
                      %build-inputs)
            #t)))
 
-    (build-expression->derivation store "pam.d" (%current-system)
-                                  builder
-                                  (zip names files))))
+    (derivation-expression "pam.d" (%current-system) builder (zip names files))))
 
 (define %pam-other-services
   ;; The "other" PAM configuration, which denies everything (see
diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm
index 4f59b2b325..654fd4d55b 100644
--- a/gnu/system/shadow.scm
+++ b/gnu/system/shadow.scm
@@ -20,6 +20,7 @@
   #:use-module (guix store)
   #:use-module (guix records)
   #:use-module (guix packages)
+  #:use-module (guix monads)
   #:use-module ((gnu packages system)
                 #:select (shadow))
   #:use-module (srfi srfi-1)
@@ -72,7 +73,7 @@
   (id             user-group-id)
   (members        user-group-members (default '())))
 
-(define (group-file store groups)
+(define (group-file groups)
   "Return a /etc/group file for GROUPS, a list of <user-group> objects."
   (define contents
     (let loop ((groups groups)
@@ -87,9 +88,9 @@
         (()
          (string-join (reverse result) "\n" 'suffix)))))
 
-  (add-text-to-store store "group" contents))
+  (text-file "group" contents))
 
-(define* (passwd-file store accounts #:key shadow?)
+(define* (passwd-file accounts #:key shadow?)
   "Return a password file for ACCOUNTS, a list of <user-account> objects.  If
 SHADOW? is true, then it is a /etc/shadow file, otherwise it is a /etc/passwd
 file."
@@ -114,28 +115,27 @@ file."
         (()
          (string-join (reverse result) "\n" 'suffix)))))
 
-  (add-text-to-store store (if shadow? "shadow" "passwd")
-                     contents '()))
+  (text-file (if shadow? "shadow" "passwd") contents))
 
-(define* (guix-build-accounts store count #:key
+(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."
-  (let* ((gid*     gid)
-         (no-login (string-append (package-output store shadow) "/sbin/nologin")))
-    (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 no-login)))
-            1+
-            1)))
+  (mlet* %store-monad ((gid* -> gid)
+                       (no-login (package-file shadow "sbin/nologin")))
+    (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 no-login)))
+                    1+
+                    1))))
 
 ;;; shadow.scm ends here
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 83b9f33456..db055fa5fc 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -21,6 +21,7 @@
   #:use-module (guix store)
   #:use-module (guix derivations)
   #:use-module (guix packages)
+  #:use-module (guix monads)
   #:use-module ((gnu packages base)
                 #:select (%final-inputs
                           guile-final gcc-final glibc-final
@@ -58,7 +59,7 @@
 ;;;
 ;;; Code:
 
-(define* (expression->derivation-in-linux-vm store name exp
+(define* (expression->derivation-in-linux-vm name exp
                                              #:key
                                              (system (%current-system))
                                              (inputs '())
@@ -89,23 +90,23 @@ made available under the /xchg CIFS share."
   ;; `build-expression->derivation'.
 
   (define input-alist
-    (map (match-lambda
-          ((input (? package? package))
-           `(,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))
-
-  (define exp*
-    ;; EXP, but with INPUTS available.
-    `(let ((%build-inputs ',input-alist))
-       ,exp))
+    (with-monad %store-monad
+      (map (match-lambda
+            ((input (? package? package))
+             (mlet %store-monad ((out (package-file package #:system system)))
+               (return `(,input . ,out))))
+            ((input (? package? package) sub-drv)
+             (mlet %store-monad ((out (package-file package
+                                                    #:output sub-drv
+                                                    #:system system)))
+               (return `(,input . ,out))))
+            ((input (? derivation? drv))
+             (return `(,input . ,(derivation->output-path drv))))
+            ((input (? derivation? drv) sub-drv)
+             (return `(,input . ,(derivation->output-path drv sub-drv))))
+            ((input (and (? string?) (? store-path?) file))
+             (return `(,input . ,file))))
+           inputs)))
 
   (define builder
     ;; Code that launches the VM that evaluates EXP.
@@ -167,34 +168,43 @@ made available under the /xchg CIFS share."
                       (mkdir out)
                       (copy-recursively "xchg" out)))))))
 
-  (let ((user-builder (add-text-to-store store "builder-in-linux-vm"
-                                         (object->string exp*)
-                                         '()))
-        (->drv        (cut package-derivation store <> system))
-        (coreutils    (car (assoc-ref %final-inputs "coreutils"))))
-    (build-expression->derivation store name system builder
-                                  `(("qemu" ,(->drv qemu))
-                                    ("linux" ,(->drv linux))
-                                    ("initrd" ,(->drv initrd))
-                                    ("coreutils" ,(->drv coreutils))
-                                    ("builder" ,user-builder)
-                                    ,@(map (match-lambda
-                                            ((name (? package? package)
-                                                   sub-drv ...)
-                                             `(,name ,(->drv package)
-                                                     ,@sub-drv))
-                                            ((name (? string? file))
-                                             `(,name ,file))
-                                            (tuple tuple))
-                                           inputs))
-                                  #:env-vars env-vars
-                                  #:modules (delete-duplicates
-                                             `((guix build utils)
-                                               ,@modules))
-                                  #:guile-for-build guile-for-build
-                                  #:references-graphs references-graphs)))
-
-(define* (qemu-image store #:key
+
+  (define (lower-inputs inputs)
+    ;; Turn any package in INPUTS into a derivation.
+    (with-monad %store-monad
+      (sequence %store-monad
+                (map (match-lambda
+                      ((name (? package? package) sub-drv ...)
+                       (mlet %store-monad ((drv (package->derivation package)))
+                         (return `(,name ,drv ,@sub-drv))))
+                      ((name (? string? file))
+                       (return `(,name ,file)))
+                      (tuple
+                       (return tuple)))
+                     inputs))))
+
+  (mlet* %store-monad
+      ((input-alist  (sequence %store-monad input-alist))
+       (exp* ->      `(let ((%build-inputs ',input-alist))
+                        ,exp))
+       (user-builder (text-file "builder-in-linux-vm"
+                                (object->string exp*)))
+       (coreutils -> (car (assoc-ref %final-inputs "coreutils")))
+       (inputs       (lower-inputs `(("qemu" ,qemu)
+                                     ("linux" ,linux)
+                                     ("initrd" ,initrd)
+                                     ("coreutils" ,coreutils)
+                                     ("builder" ,user-builder)
+                                     ,@inputs))))
+    (derivation-expression name system builder inputs
+                           #:env-vars env-vars
+                           #:modules (delete-duplicates
+                                      `((guix build utils)
+                                        ,@modules))
+                           #:guile-for-build guile-for-build
+                           #:references-graphs references-graphs)))
+
+(define* (qemu-image #:key
                      (name "qemu-image")
                      (system (%current-system))
                      (disk-image-size (* 100 (expt 2 20)))
@@ -215,203 +225,206 @@ 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))
-      `(,name . ,(derivation->output-path
-                  (package-derivation store package system))))
-     ((name (? package? package) sub-drv)
-      `(,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))))
-
-  (expression->derivation-in-linux-vm
-   store "qemu-image"
-   `(let ()
-      (use-modules (ice-9 rdelim)
-                   (srfi srfi-1)
-                   (guix build utils)
-                   (guix build linux-initrd))
-
-      (let ((parted  (string-append (assoc-ref %build-inputs "parted")
-                                    "/sbin/parted"))
-            (mkfs    (string-append (assoc-ref %build-inputs "e2fsprogs")
-                                    "/sbin/mkfs.ext3"))
-            (grub    (string-append (assoc-ref %build-inputs "grub")
-                                    "/sbin/grub-install"))
-            (umount  (string-append (assoc-ref %build-inputs "util-linux")
-                                    "/bin/umount")) ; XXX: add to Guile
-            (grub.cfg (assoc-ref %build-inputs "grub.cfg")))
-
-        (define (read-reference-graph port)
-          ;; Return a list of store paths from the reference graph at PORT.
-          ;; The data at PORT is the format produced by #:references-graphs.
-          (let loop ((line   (read-line port))
-                     (result '()))
-            (cond ((eof-object? line)
-                   (delete-duplicates result))
-                  ((string-prefix? "/" line)
-                   (loop (read-line port)
-                         (cons line result)))
-                  (else
-                   (loop (read-line port)
-                         result)))))
-
-        (define (things-to-copy)
-          ;; Return the list of store files to copy to the image.
-          (define (graph-from-file file)
-            (call-with-input-file file
-              read-reference-graph))
-
-          ,(match inputs-to-copy
-             (((graph-files . _) ...)
-              `(let* ((graph-files ',(map (cut string-append "/xchg/" <>)
-                                          graph-files))
-                      (paths       (append-map graph-from-file graph-files)))
-                 (delete-duplicates paths)))
-             (#f ''())))
-
-        ;; GRUB is full of shell scripts.
-        (setenv "PATH"
-                (string-append (dirname grub) ":"
-                               (assoc-ref %build-inputs "coreutils") "/bin:"
-                               (assoc-ref %build-inputs "findutils") "/bin:"
-                               (assoc-ref %build-inputs "sed") "/bin:"
-                               (assoc-ref %build-inputs "grep") "/bin:"
-                               (assoc-ref %build-inputs "gawk") "/bin"))
-
-        (display "creating partition table...\n")
-        (and (zero? (system* parted "/dev/vda" "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"))
-                    (let ((store (string-append "/fs" ,%store-directory)))
-                      (display "mounting partition...\n")
-                      (mkdir "/fs")
-                      (mount "/dev/vda1" "/fs" "ext3")
-                      (mkdir-p "/fs/boot/grub")
-                      (symlink grub.cfg "/fs/boot/grub/grub.cfg")
-
-                      ;; Populate the image's store.
-                      (mkdir-p store)
-                      (chmod store #o1775)
-                      (for-each (lambda (thing)
-                                  (copy-recursively thing
-                                                    (string-append "/fs"
-                                                                   thing)))
-                                (cons grub.cfg (things-to-copy)))
-
-                      ;; 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)))
-                            ((('directory name uid gid) rest ...)
-                             (let ((dir (string-append "/fs" name)))
-                               (loop rest
-                                     (cons* `(chown ,dir ,uid ,gid)
-                                            `(mkdir-p ,dir)
-                                            statements))))
-                            (((new '-> old) rest ...)
-                             (loop rest
-                                   (cons `(symlink ,old
-                                                   ,(string-append "/fs" new))
-                                         statements)))))
-
-                      (and=> (assoc-ref %build-inputs "populate")
-                             (lambda (populate)
-                               (chdir "/fs")
-                               (primitive-load populate)
-                               (chdir "/")))
-
-                      (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
-                                    ;; /nix/store, which is the host,
-                                    ;; read-only store.
-                                    (unless (eq? (stat:type s) 'symlink)
-                                      (utime file 0 0 0 0))))
-                                (find-files "/fs" ".*"))
-
-                      (and (zero?
-                            (system* grub "--no-floppy"
-                                     "--boot-directory" "/fs/boot"
-                                     "/dev/vda"))
-                           (zero? (system* umount "/fs"))
-                           (reboot))))))))
-   #:system system
-   #:inputs `(("parted" ,parted)
-              ("grub" ,grub)
-              ("e2fsprogs" ,e2fsprogs)
-              ("grub.cfg" ,grub-configuration)
-
-              ;; For shell scripts.
-              ("sed" ,(car (assoc-ref %final-inputs "sed")))
-              ("grep" ,(car (assoc-ref %final-inputs "grep")))
-              ("coreutils" ,(car (assoc-ref %final-inputs "coreutils")))
-              ("findutils" ,(car (assoc-ref %final-inputs "findutils")))
-              ("gawk" ,(car (assoc-ref %final-inputs "gawk")))
-              ("util-linux" ,util-linux)
-
-              ,@(if initialize-store?
-                    `(("guix" ,guix))
-                    '())
-
-              ,@inputs-to-copy)
-   #:make-disk-image? #t
-   #:disk-image-size disk-image-size
-   #:references-graphs (map input->name+derivation inputs-to-copy)
-   #:modules '((guix build utils)
-               (guix build linux-initrd))))
+  (define (input->name+derivation tuple)
+    (with-monad %store-monad
+      (match tuple
+        ((name (? package? package))
+         (mlet %store-monad ((drv (package->derivation package system)))
+           (return `(,name . ,(derivation->output-path drv)))))
+        ((name (? package? package) sub-drv)
+         (mlet %store-monad ((drv (package->derivation package system)))
+           (return `(,name . ,(derivation->output-path drv sub-drv)))))
+        ((name (? derivation? drv))
+         (return `(,name . ,(derivation->output-path drv))))
+        ((name (? derivation? drv) sub-drv)
+         (return `(,name . ,(derivation->output-path drv sub-drv))))
+        ((input (and (? string?) (? store-path?) file))
+         (return `(,input . ,file))))))
+
+  (mlet %store-monad
+      ((graph (sequence %store-monad
+                        (map input->name+derivation inputs-to-copy))))
+   (expression->derivation-in-linux-vm
+    "qemu-image"
+    `(let ()
+       (use-modules (ice-9 rdelim)
+                    (srfi srfi-1)
+                    (guix build utils)
+                    (guix build linux-initrd))
+
+       (let ((parted  (string-append (assoc-ref %build-inputs "parted")
+                                     "/sbin/parted"))
+             (mkfs    (string-append (assoc-ref %build-inputs "e2fsprogs")
+                                     "/sbin/mkfs.ext3"))
+             (grub    (string-append (assoc-ref %build-inputs "grub")
+                                     "/sbin/grub-install"))
+             (umount  (string-append (assoc-ref %build-inputs "util-linux")
+                                     "/bin/umount")) ; XXX: add to Guile
+             (grub.cfg (assoc-ref %build-inputs "grub.cfg")))
+
+         (define (read-reference-graph port)
+           ;; Return a list of store paths from the reference graph at PORT.
+           ;; The data at PORT is the format produced by #:references-graphs.
+           (let loop ((line   (read-line port))
+                      (result '()))
+             (cond ((eof-object? line)
+                    (delete-duplicates result))
+                   ((string-prefix? "/" line)
+                    (loop (read-line port)
+                          (cons line result)))
+                   (else
+                    (loop (read-line port)
+                          result)))))
+
+         (define (things-to-copy)
+           ;; Return the list of store files to copy to the image.
+           (define (graph-from-file file)
+             (call-with-input-file file
+               read-reference-graph))
+
+           ,(match inputs-to-copy
+              (((graph-files . _) ...)
+               `(let* ((graph-files ',(map (cut string-append "/xchg/" <>)
+                                           graph-files))
+                       (paths       (append-map graph-from-file graph-files)))
+                  (delete-duplicates paths)))
+              (#f ''())))
+
+         ;; GRUB is full of shell scripts.
+         (setenv "PATH"
+                 (string-append (dirname grub) ":"
+                                (assoc-ref %build-inputs "coreutils") "/bin:"
+                                (assoc-ref %build-inputs "findutils") "/bin:"
+                                (assoc-ref %build-inputs "sed") "/bin:"
+                                (assoc-ref %build-inputs "grep") "/bin:"
+                                (assoc-ref %build-inputs "gawk") "/bin"))
+
+         (display "creating partition table...\n")
+         (and (zero? (system* parted "/dev/vda" "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"))
+                     (let ((store (string-append "/fs" ,%store-directory)))
+                       (display "mounting partition...\n")
+                       (mkdir "/fs")
+                       (mount "/dev/vda1" "/fs" "ext3")
+                       (mkdir-p "/fs/boot/grub")
+                       (symlink grub.cfg "/fs/boot/grub/grub.cfg")
+
+                       ;; Populate the image's store.
+                       (mkdir-p store)
+                       (chmod store #o1775)
+                       (for-each (lambda (thing)
+                                   (copy-recursively thing
+                                                     (string-append "/fs"
+                                                                    thing)))
+                                 (cons grub.cfg (things-to-copy)))
+
+                       ;; 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)))
+                             ((('directory name uid gid) rest ...)
+                              (let ((dir (string-append "/fs" name)))
+                                (loop rest
+                                      (cons* `(chown ,dir ,uid ,gid)
+                                             `(mkdir-p ,dir)
+                                             statements))))
+                             (((new '-> old) rest ...)
+                              (loop rest
+                                    (cons `(symlink ,old
+                                                    ,(string-append "/fs" new))
+                                          statements)))))
+
+                       (and=> (assoc-ref %build-inputs "populate")
+                              (lambda (populate)
+                                (chdir "/fs")
+                                (primitive-load populate)
+                                (chdir "/")))
+
+                       (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
+                                     ;; /nix/store, which is the host,
+                                     ;; read-only store.
+                                     (unless (eq? (stat:type s) 'symlink)
+                                       (utime file 0 0 0 0))))
+                                 (find-files "/fs" ".*"))
+
+                       (and (zero?
+                             (system* grub "--no-floppy"
+                                      "--boot-directory" "/fs/boot"
+                                      "/dev/vda"))
+                            (zero? (system* umount "/fs"))
+                            (reboot))))))))
+    #:system system
+    #:inputs `(("parted" ,parted)
+               ("grub" ,grub)
+               ("e2fsprogs" ,e2fsprogs)
+               ("grub.cfg" ,grub-configuration)
+
+               ;; For shell scripts.
+               ("sed" ,(car (assoc-ref %final-inputs "sed")))
+               ("grep" ,(car (assoc-ref %final-inputs "grep")))
+               ("coreutils" ,(car (assoc-ref %final-inputs "coreutils")))
+               ("findutils" ,(car (assoc-ref %final-inputs "findutils")))
+               ("gawk" ,(car (assoc-ref %final-inputs "gawk")))
+               ("util-linux" ,util-linux)
+
+               ,@(if initialize-store?
+                     `(("guix" ,guix))
+                     '())
+
+               ,@inputs-to-copy)
+    #:make-disk-image? #t
+    #:disk-image-size disk-image-size
+    #:references-graphs graph
+    #:modules '((guix build utils)
+                (guix build linux-initrd)))))
 
 
 ;;;
 ;;; Stand-alone VM image.
 ;;;
 
-(define* (union store inputs
+(define* (union 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
+    '(begin
        (use-modules (guix build union))
 
        (setvbuf (current-output-port) _IOLBF)
@@ -423,132 +436,124 @@ input tuples."
                  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)
+  (mlet %store-monad
+      ((inputs (sequence %store-monad
+                         (map (match-lambda
+                               ((name (? package? p))
+                                (mlet %store-monad
+                                    ((drv (package->derivation p system)))
+                                  (return `(,name ,drv))))
+                               ((name (? package? p) output)
+                                (mlet %store-monad
+                                    ((drv (package->derivation p system)))
+                                  (return `(,name ,drv ,output))))
+                               (x
+                                (return x)))
+                              inputs))))
+    (derivation-expression name system builder
+                           inputs
+                           #:modules '((guix build union))
+                           #:guile-for-build guile)))
+
+(define (system-qemu-image)
   "Return the derivation of a QEMU image of the GNU system."
-  (define motd
-    (add-text-to-store store "motd" "
+  (define build-user-gid 30000)
+
+  (mlet* %store-monad
+      ((motd (text-file "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
-                            #:motd motd)))
-
-  (define %dmd-services
-    ;; Services run by dmd.
-    (list (host-name-service store "gnu")
-          (mingetty-service store "tty1")
-          (mingetty-service store "tty2")
-          (mingetty-service store "tty3")
-          (mingetty-service store "tty4")
-          (mingetty-service store "tty5")
-          (mingetty-service store "tty6")
-          (syslog-service store)
-          (guix-service store)
-          (nscd-service store)
-
-          ;; QEMU networking settings.
-          (static-networking-service store "eth0" "10.0.2.10"
-                                     #:gateway "10.0.2.2")))
-
-  (define build-user-gid 30000)
-
-  (define build-accounts
-    (guix-build-accounts store 10 #:gid build-user-gid))
-
-  (define resolv.conf
-    ;; Name resolution for default QEMU settings.
-    (add-text-to-store store "resolv.conf"
-                       "nameserver 10.0.2.3\n"))
-
-  (define etc-services
-    (string-append (package-output store net-base) "/etc/services"))
-  (define etc-protocols
-    (string-append (package-output store net-base) "/etc/protocols"))
-  (define etc-rpc
-    (string-append (package-output store net-base) "/etc/rpc"))
-
-  (parameterize ((%guile-for-build (package-derivation store guile-final)))
-    (let* ((bash-drv  (package-derivation store bash))
-           (bash-file (string-append (derivation->output-path bash-drv)
-                                     "/bin/bash"))
-           (dmd-drv   (package-derivation store dmd))
-           (dmd-file  (string-append (derivation->output-path dmd-drv)
-                                     "/bin/dmd"))
-           (dmd-conf  (dmd-configuration-file store %dmd-services))
-           (accounts  (cons* (user-account
-                              (name "root")
-                              (password "")
-                              (uid 0) (gid 0)
-                              (comment "System administrator")
-                              (home-directory "/")
-                              (shell bash-file))
-                             (user-account
-                              (name "guest")
-                              (password "")
-                              (uid 1000) (gid 100)
-                              (comment "Guest of GNU")
-                              (home-directory "/home/guest")
-                              (shell bash-file))
-                             build-accounts))
-           (passwd    (passwd-file store accounts))
-           (shadow    (passwd-file store accounts #:shadow? #t))
-           (group     (group-file store
-                                  (list (user-group
-                                         (name "root")
-                                         (id 0))
-                                        (user-group
-                                         (name "users")
-                                         (id 100)
-                                         (members '("guest")))
-                                        (user-group
-                                         (name "guixbuild")
-                                         (id build-user-gid)
-                                         (members (map user-account-name
-                                                       build-accounts))))))
-           (pam.d-drv (pam-services->directory store %pam-services))
-           (pam.d     (derivation->output-path pam.d-drv))
-
-           (packages `(("coreutils" ,coreutils)
-                       ("bash" ,bash)
-                       ("guile" ,guile-2.0)
-                       ("dmd" ,dmd)
-                       ("gcc" ,gcc-final)
-                       ("libc" ,glibc-final)
-                       ("inetutils" ,inetutils)
-                       ("findutils" ,findutils)
-                       ("grep" ,grep)
-                       ("sed" ,sed)
-                       ("procps" ,procps)
-                       ("psmisc" ,psmisc)
-                       ("zile" ,zile)
-                       ("guix" ,guix)))
-
-           ;; 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 "
+       (%pam-services ->
+                      ;; Services known to PAM.
+                      (list %pam-other-services
+                            (unix-pam-service "login"
+                                              #:allow-empty-passwords? #t
+                                              #:motd motd)))
+
+       (services (listm %store-monad
+                        (host-name-service "gnu")
+                        (mingetty-service "tty1")
+                        (mingetty-service "tty2")
+                        (mingetty-service "tty3")
+                        (mingetty-service "tty4")
+                        (mingetty-service "tty5")
+                        (mingetty-service "tty6")
+                        (syslog-service)
+                        (guix-service)
+                        (nscd-service)
+
+                        ;; QEMU networking settings.
+                        (static-networking-service "eth0" "10.0.2.10"
+                                                   #:gateway "10.0.2.2")))
+
+       (build-accounts (guix-build-accounts 10 #:gid build-user-gid))
+
+       (resolv.conf
+        ;; Name resolution for default QEMU settings.
+        (text-file "resolv.conf" "nameserver 10.0.2.3\n"))
+
+       (etc-services  (package-file net-base "etc/services"))
+       (etc-protocols (package-file net-base "etc/protocols"))
+       (etc-rpc       (package-file net-base "etc/rpc"))
+
+       (bash-file (package-file bash "bin/bash"))
+       (dmd-file  (package-file dmd "bin/dmd"))
+       (dmd-conf  (dmd-configuration-file services))
+       (accounts -> (cons* (user-account
+                            (name "root")
+                            (password "")
+                            (uid 0) (gid 0)
+                            (comment "System administrator")
+                            (home-directory "/")
+                            (shell bash-file))
+                           (user-account
+                            (name "guest")
+                            (password "")
+                            (uid 1000) (gid 100)
+                            (comment "Guest of GNU")
+                            (home-directory "/home/guest")
+                            (shell bash-file))
+                           build-accounts))
+       (passwd    (passwd-file accounts))
+       (shadow    (passwd-file accounts #:shadow? #t))
+       (group     (group-file (list (user-group
+                                     (name "root")
+                                     (id 0))
+                                    (user-group
+                                     (name "users")
+                                     (id 100)
+                                     (members '("guest")))
+                                    (user-group
+                                     (name "guixbuild")
+                                     (id build-user-gid)
+                                     (members (map user-account-name
+                                                   build-accounts))))))
+       (pam.d-drv (pam-services->directory %pam-services))
+       (pam.d ->  (derivation->output-path pam.d-drv))
+
+       (packages -> `(("coreutils" ,coreutils)
+                      ("bash" ,bash)
+                      ("guile" ,guile-2.0)
+                      ("dmd" ,dmd)
+                      ("gcc" ,gcc-final)
+                      ("libc" ,glibc-final)
+                      ("inetutils" ,inetutils)
+                      ("findutils" ,findutils)
+                      ("grep" ,grep)
+                      ("sed" ,sed)
+                      ("procps" ,procps)
+                      ("psmisc" ,psmisc)
+                      ("zile" ,zile)
+                      ("guix" ,guix)))
+
+       ;; TODO: Replace with a real profile with a manifest.
+       ;; TODO: Generate bashrc from packages' search-paths.
+       (profile-drv (union packages
+                           #:name "default-profile"))
+       (profile ->  (derivation->output-path profile-drv))
+       (bashrc   (text-file "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
@@ -557,7 +562,7 @@ alias ls='ls -p --color'
 alias ll='ls -l'
 ")))
 
-           (issue    (add-text-to-store store "issue" "
+       (issue    (text-file "issue" "
 This is an alpha preview of the GNU system.  Welcome.
 
 This image features the GNU Guix package manager, which was used to
@@ -567,67 +572,63 @@ GNU dmd (http://www.gnu.org/software/dmd/).
 You can log in as 'guest' or 'root' with no password.
 "))
 
-           (populate `((directory "/nix/store" 0 ,build-user-gid)
-                       (directory "/etc")
-                       (directory "/var/log")     ; for dmd
-                       (directory "/var/run/nscd")
-                       ("/etc/shadow" -> ,shadow)
-                       ("/etc/passwd" -> ,passwd)
-                       ("/etc/group" -> ,group)
-                       ("/etc/login.defs" -> "/dev/null")
-                       ("/etc/pam.d" -> ,pam.d)
-                       ("/etc/resolv.conf" -> ,resolv.conf)
-                       ("/etc/profile" -> ,bashrc)
-                       ("/etc/issue" -> ,issue)
-                       ("/etc/services" -> ,etc-services)
-                       ("/etc/protocols" -> ,etc-protocols)
-                       ("/etc/rpc" -> ,etc-rpc)
-                       (directory "/var/nix/gcroots")
-                       ("/var/nix/gcroots/default-profile" -> ,profile)
-                       (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)))
-           (out     (derivation->output-path
-                     (package-derivation store mingetty)))
-           (boot    (add-text-to-store store "boot"
-                                       (object->string
-                                        `(execl ,dmd-file "dmd"
-                                                "--config" ,dmd-conf))))
-           (entries  (list (menu-entry
-                            (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)))
-      (qemu-image store
-                  #:grub-configuration grub.cfg
-                  #:populate populate
-                  #:disk-image-size (* 550 (expt 2 20))
-                  #:initialize-store? #t
-                  #:inputs-to-copy `(("boot" ,boot)
-                                     ("linux" ,linux-libre)
-                                     ("initrd" ,gnu-system-initrd)
-                                     ("pam.d" ,pam.d-drv)
-                                     ("profile" ,profile-drv)
-
-                                     ;; Configuration.
-                                     ("dmd.conf" ,dmd-conf)
-                                     ("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)
-                                     ("net-base" ,net-base)
-                                     ,@(append-map service-inputs
-                                                   %dmd-services))))))
+       (populate -> `((directory "/nix/store" 0 ,build-user-gid)
+                      (directory "/etc")
+                      (directory "/var/log")      ; for dmd
+                      (directory "/var/run/nscd")
+                      ("/etc/shadow" -> ,shadow)
+                      ("/etc/passwd" -> ,passwd)
+                      ("/etc/group" -> ,group)
+                      ("/etc/login.defs" -> "/dev/null")
+                      ("/etc/pam.d" -> ,pam.d)
+                      ("/etc/resolv.conf" -> ,resolv.conf)
+                      ("/etc/profile" -> ,bashrc)
+                      ("/etc/issue" -> ,issue)
+                      ("/etc/services" -> ,etc-services)
+                      ("/etc/protocols" -> ,etc-protocols)
+                      ("/etc/rpc" -> ,etc-rpc)
+                      (directory "/var/nix/gcroots")
+                      ("/var/nix/gcroots/default-profile" -> ,profile)
+                      (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)))
+       (boot     (text-file "boot" (object->string
+                                    `(execl ,dmd-file "dmd"
+                                            "--config" ,dmd-conf))))
+       (entries -> (list (return (menu-entry
+                                  (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 entries)))
+    (qemu-image  #:grub-configuration grub.cfg
+                 #:populate populate
+                 #:disk-image-size (* 550 (expt 2 20))
+                 #:initialize-store? #t
+                 #:inputs-to-copy `(("boot" ,boot)
+                                    ("linux" ,linux-libre)
+                                    ("initrd" ,gnu-system-initrd)
+                                    ("pam.d" ,pam.d-drv)
+                                    ("profile" ,profile-drv)
+
+                                    ;; Configuration.
+                                    ("dmd.conf" ,dmd-conf)
+                                    ("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)
+                                    ("net-base" ,net-base)
+                                    ,@(append-map service-inputs
+                                                  services)))))
 
 ;;; vm.scm ends here