gnu: vm: Change #:populate to a list of directives.

* gnu/system/vm.scm (qemu-image): Change 'populate' parameter to be a
  list of directives.
  (system-qemu-image): Adjust accordingly.

1 files changed, 28 insertions, 21 deletions

diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index d8c2b95d75..a0669ae865 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -211,9 +211,10 @@ INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied
 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))
@@ -326,6 +327,22 @@ It can be used to provide additional files, such as /etc files."
                                       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")
@@ -365,9 +382,6 @@ 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))
                     '())
@@ -473,21 +487,14 @@ alias ls='ls -p --color'
 alias ll='ls -l'
 ")))
 
-           (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")
-                                   (symlink ,bashrc "etc/profile")
-                                   (mkdir-p "var/run")))
-                               (list passwd)))
+           (populate `((directory "/etc")
+                       (directory "/var/log")
+                       (directory "/var/run")
+                       ("/etc/shadow" -> ,shadow)
+                       ("/etc/passwd" -> ,passwd)
+                       ("/etc/login.defs" -> "/dev/null")
+                       ("/etc/pam.d" -> ,pam.d)
+                       ("/etc/profile" -> ,bashrc)))
            (out     (derivation->output-path
                      (package-derivation store mingetty)))
            (boot    (add-text-to-store store "boot"