From 2e7b5cea8cc5e50e8c4832e96ce7b40b4f99906f Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 9 Apr 2014 01:20:19 +0200
Subject: guix system: Add 'vm-image' action and '--image-size' option.

* guix/scripts/system.scm (%options): Add --image-size.
  (%default-options): Add 'image-size'.
  (guix-system)[parse-options]: Handle the 'vm-image' action.
  Honor them.
  (show-help): Update accordingly.
* doc/guix.texi (Invoking guix system): Add 'vm-image'.
---
 doc/guix.texi           |  8 +++++++-
 guix/scripts/system.scm | 44 +++++++++++++++++++++++++++++++-------------
 2 files changed, 38 insertions(+), 14 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 863fce8307..ebd1ff5416 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -2982,7 +2982,8 @@ guix system @var{options}@dots{} @var{action} @var{file}
 
 @var{file} must be the name of a file containing an
 @code{operating-system} declaration.  @var{action} specifies how the
-operating system is instantiate.  Currently only one value is supported:
+operating system is instantiate.  Currently the following values are
+supported:
 
 @table @code
 @item vm
@@ -2991,6 +2992,11 @@ Build a virtual machine that contain the operating system declared in
 @var{file}, and return a script to run that virtual machine (VM).
 
 The VM shares its store with the host system.
+
+@item vm-image
+Return a virtual machine image of the operating system declared in
+@var{file} that stands alone.  Use the @option{--image-size} option to
+specify the size of the image.
 @end table
 
 @var{options} can contain any of the common build options provided by
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 823713eada..582027244c 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -71,9 +71,12 @@
 (define (show-help)
   (display (_ "Usage: guix system [OPTION] ACTION FILE
 Build the operating system declared in FILE according to ACTION.\n"))
-  (display (_ "Currently the only valid value for ACTION is 'vm', which builds
-a virtual machine of the given operating system.\n"))
+  (display (_ "Currently the only valid values for ACTION are 'vm', which builds
+a virtual machine of the given operating system that shares the host's store,
+and 'vm-image', which builds a virtual machine image that stands alone.\n"))
   (show-build-options-help)
+  (display (_ "
+      --image-size=SIZE  for 'vm-image', produce an image of SIZE"))
   (newline)
   (display (_ "
   -h, --help             display this help and exit"))
@@ -91,6 +94,10 @@ a virtual machine of the given operating system.\n"))
          (option '(#\V "version") #f #f
                  (lambda args
                    (show-version-and-exit "guix system")))
+         (option '("image-size") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'image-size (size->number arg)
+                               result)))
          (option '(#\n "dry-run") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'dry-run? #t result)))
@@ -102,7 +109,8 @@ a virtual machine of the given operating system.\n"))
     (substitutes? . #t)
     (build-hook? . #t)
     (max-silent-time . 3600)
-    (verbosity . 0)))
+    (verbosity . 0)
+    (image-size . ,(* 900 (expt 2 20)))))
 
 
 ;;;
@@ -123,21 +131,31 @@ a virtual machine of the given operating system.\n"))
                             (alist-cons 'argument arg result)))
                       (let ((action (string->symbol arg)))
                         (case action
-                          ((vm) (alist-cons 'action action result))
+                          ((vm)
+                           (alist-cons 'action action result))
+                          ((vm-image)
+                           (alist-cons 'action action result))
                           (else (leave (_ "~a: unknown action~%")
                                        action))))))
                 %default-options))
 
   (with-error-handling
-    (let* ((opts  (parse-options))
-           (file  (assoc-ref opts 'argument))
-           (os    (if file
-                      (read-operating-system file)
-                      (leave (_ "no configuration file specified~%"))))
-           (mdrv  (system-qemu-image/shared-store-script os))
-           (store (open-connection))
-           (dry?  (assoc-ref opts 'dry-run?))
-           (drv   (run-with-store store mdrv)))
+    (let* ((opts   (parse-options))
+           (file   (assoc-ref opts 'argument))
+           (action (assoc-ref opts 'action))
+           (os     (if file
+                       (read-operating-system file)
+                       (leave (_ "no configuration file specified~%"))))
+           (mdrv   (case action
+                     ((vm-image)
+                      (let ((size (assoc-ref opts 'image-size)))
+                        (system-qemu-image os
+                                           #:disk-image-size size)))
+                     ((vm)
+                      (system-qemu-image/shared-store-script os))))
+           (store  (open-connection))
+           (dry?   (assoc-ref opts 'dry-run?))
+           (drv    (run-with-store store mdrv)))
       (set-build-options-from-command-line store opts)
       (show-what-to-build store (list drv)
                           #:dry-run? dry?
-- 
cgit v1.2.3