4 files changed, 30 insertions(+), 13 deletions(-)

M gnu/system/vm.scm
M guix/build/install.scm
M guix/build/vm.scm
M guix/scripts/system.scm

@@ 197,6 197,7 @@ made available under the /xchg CIFS share."
                      (disk-image-format "qcow2")
                      (file-system-type "ext4")
                      file-system-label
+                     os-derivation
                      grub-configuration
                      (register-closures? #t)
                      (inputs '())


@@ 204,9 205,9 @@ made available under the /xchg CIFS share."
   "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
 'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.
 Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
-partition.  The returned image is a full disk image, with a GRUB installation
-that uses GRUB-CONFIGURATION as its configuration file (GRUB-CONFIGURATION
-must be the name of a file in the VM.)
+partition.  The returned image is a full disk image that runs OS-DERIVATION,
+with a GRUB installation that uses GRUB-CONFIGURATION as its configuration
+file (GRUB-CONFIGURATION must be the name of a file in the VM.)
 
 INPUTS is a list of inputs (as for packages).  When COPY-INPUTS? is true, copy
 all of INPUTS into the image being built.  When REGISTER-CLOSURES? is true,


@@ 240,6 241,7 @@ the image."
                              (((names . _) ...)
                               names))))
             (initialize-hard-disk "/dev/vda"
+                                  #:system-directory #$os-derivation
                                   #:grub.cfg #$grub-configuration
                                   #:closures graphs
                                   #:copy-closures? #$copy-inputs?


@@ 298,6 300,7 @@ to USB sticks meant to be read-only."
     (mlet* %store-monad ((os-drv   (operating-system-derivation os))
                          (grub.cfg (operating-system-grub.cfg os)))
       (qemu-image #:name name
+                  #:os-derivation os-drv
                   #:grub-configuration grub.cfg
                   #:disk-image-size disk-image-size
                   #:disk-image-format "raw"


@@ 334,7 337,8 @@ of the GNU system as described by OS."
     (mlet* %store-monad
         ((os-drv      (operating-system-derivation os))
          (grub.cfg    (operating-system-grub.cfg os)))
-      (qemu-image  #:grub-configuration grub.cfg
+      (qemu-image  #:os-derivation os-drv
+                   #:grub-configuration grub.cfg
                    #:disk-image-size disk-image-size
                    #:file-system-type file-system-type
                    #:inputs `(("system" ,os-drv)


@@ 376,7 380,8 @@ with the host."
   (mlet* %store-monad
       ((os-drv      (operating-system-derivation os))
        (grub.cfg    (operating-system-grub.cfg os)))
-    (qemu-image #:grub-configuration grub.cfg
+    (qemu-image #:os-derivation os-drv
+                #:grub-configuration grub.cfg
                 #:disk-image-size disk-image-size
                 #:inputs `(("system" ,os-drv))
 

@@ 83,21 83,30 @@ STORE."
     (directory "/var/empty")                        ; for no-login accounts
     (directory "/var/run")
     (directory "/run")
+    (directory "/var/guix/profiles/per-user/root" 0 0)
+
+    ;; Link to the initial system generation.
+    ("/var/guix/profiles/system" -> "system-1-link")
+
     ("/var/guix/gcroots/booted-system" -> "/run/booted-system")
     ("/var/guix/gcroots/current-system" -> "/run/current-system")
+
     (directory "/bin")
     ("/bin/sh" -> "/run/current-system/profile/bin/bash")
     (directory "/tmp" 0 0 #o1777)                 ; sticky bit
-    (directory "/var/guix/profiles/per-user/root" 0 0)
 
     (directory "/root" 0 0)                       ; an exception
     (directory "/home" 0 0)))
 
-(define (populate-root-file-system target)
+(define (populate-root-file-system system target)
   "Make the essential non-store files and directories on TARGET.  This
-includes /etc, /var, /run, /bin/sh, etc."
+includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM."
   (for-each (cut evaluate-populate-directive <> target)
-            (directives (%store-directory))))
+            (directives (%store-directory)))
+
+  ;; Add system generation 1.
+  (symlink system
+           (string-append target "/var/guix/profiles/system-1-link")))
 
 (define (reset-timestamps directory)
   "Reset the timestamps of all the files under DIRECTORY, so that they appear

@@ 172,7 172,7 @@ volume name."
 
 (define* (initialize-root-partition target-directory
                                     #:key copy-closures? register-closures?
-                                    closures)
+                                    closures system-directory)
   "Initialize the root partition mounted at TARGET-DIRECTORY."
   (define target-store
     (string-append target-directory (%store-directory)))


@@ 203,10 203,11 @@ volume name."
 
   ;; Add the non-store directories and files.
   (display "populating...\n")
-  (populate-root-file-system target-directory))
+  (populate-root-file-system system-directory target-directory))
 
 (define* (initialize-hard-disk device
                                #:key
+                               system-directory
                                grub.cfg
                                disk-image-size
                                (file-system-type "ext4")


@@ 218,7 219,8 @@ volume name."
 partition with (optionally) FILE-SYSTEM-LABEL as its volume name, and with
 GRUB installed.  If REGISTER-CLOSURES? is true, register all of CLOSURES is
 the partition's store.  If COPY-CLOSURES? is true, copy all of CLOSURES to the
-partition."
+partition.  SYSTEM-DIRECTORY is the name of the directory of the 'system'
+derivation."
   (define target-directory
     "/fs")
 


@@ 236,6 238,7 @@ partition."
   (mount partition target-directory file-system-type)
 
   (initialize-root-partition target-directory
+                             #:system-directory system-directory
                              #:copy-closures? copy-closures?
                              #:register-closures? register-closures?
                              #:closures closures)

@@ 116,7 116,7 @@ When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG."
 
   ;; Create a bunch of additional files.
   (format log-port "populating '~a'...~%" target)
-  (populate-root-file-system target)
+  (populate-root-file-system os-dir target)
 
   (when grub?
     (unless (false-if-exception (install-grub grub.cfg device target))