04/06: vm: Estimate the disk size by default.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit a8ac4f081a9a679498ea42ccfe001f218bba3043
Author: Ludovic Courtès <address@hidden>
Date:   Fri Jun 30 00:04:38 2017 +0200

    vm: Estimate the disk size by default.
    
    * gnu/build/vm.scm (estimated-partition-size): New procedure.
    * gnu/system/vm.scm (expression->derivation-in-linux-vm):
    Change #:disk-image-size default to 'guess.
    [builder]: When DISK-IMAGE-SIZE is 'guess, use
    'estimated-partition-size' and compute and estimate of the image size.
    (qemu-image): Likewise.
    * guix/build/store-copy.scm (file-size, closure-size): New procedures.
    * guix/scripts/system.scm (%default-options): Change 'image-size' to
    'guess.
    * doc/guix.texi (Building the Installation Image): Remove '--image-size'
    flag from example.
    (Invoking guix system): Document the image size estimate.
---
 doc/guix.texi             | 12 ++++++++----
 gnu/build/vm.scm          |  7 +++++++
 gnu/system/vm.scm         | 44 +++++++++++++++++++++++++++-----------------
 guix/build/store-copy.scm | 35 ++++++++++++++++++++++++++++++++++-
 guix/scripts/system.scm   |  2 +-
 5 files changed, 77 insertions(+), 23 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 729ec08..d61a5b7 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -7877,9 +7877,8 @@ that.
 The installation image described above was built using the @command{guix
 system} command, specifically:
 
address@hidden FIXME: 1G is too much; see <http://bugs.gnu.org/23077>.
 @example
-guix system disk-image --image-size=1G gnu/system/install.scm
+guix system disk-image gnu/system/install.scm
 @end example
 
 Have a look at @file{gnu/system/install.scm} in the source tree,
@@ -16187,8 +16186,9 @@ size of the image.
 @item vm-image
 @itemx disk-image
 Return a virtual machine or disk 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.
+in @var{file} that stands alone.  By default, @command{guix system}
+estimates the size of the image needed to store the system, but you can
+use the @option{--image-size} option to specify a value.
 
 When using @code{vm-image}, the returned image is in qcow2 format, which
 the QEMU emulator can efficiently use. @xref{Running GuixSD in a VM},
@@ -16251,6 +16251,10 @@ of the given @var{size}.  @var{size} may be a number 
of bytes, or it may
 include a unit as a suffix (@pxref{Block size, size specifications,,
 coreutils, GNU Coreutils}).
 
+When this option is omitted, @command{guix system} computes an estimate
+of the image size as a function of the size of the system declared in
address@hidden
+
 @item address@hidden
 @itemx -r @var{file}
 Make @var{file} a symlink to the result, and register it as a garbage
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 7d5e613..d0bc8c3 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -46,6 +46,7 @@
             partition-flags
             partition-initializer
 
+            estimated-partition-size
             root-partition-initializer
             initialize-partition-table
             initialize-hard-disk))
@@ -150,6 +151,12 @@ the #:references-graphs parameter of 'derivation'."
   (flags       partition-flags (default '()))
   (initializer partition-initializer (default (const #t))))
 
+(define (estimated-partition-size graphs)
+  "Return the estimated size of a partition that can store the store items
+given by GRAPHS, a list of file names produced by #:references-graphs."
+  ;; Simply add a 20% overhead.
+  (round (* 1.2 (closure-size graphs))))
+
 (define (fold2 proc seed1 seed2 lst)              ;TODO: factorize
   "Like `fold', but with a single list and two seeds."
   (let loop ((result1 seed1)
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 392737d..7ac8696 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2016 Christopher Allan Webber <address@hidden>
 ;;; Copyright © 2016 Leo Famulari <address@hidden>
 ;;; Copyright © 2017 Mathieu Othacehe <address@hidden>
@@ -108,8 +108,7 @@
                                              (references-graphs #f)
                                              (memory-size 256)
                                              (disk-image-format "qcow2")
-                                             (disk-image-size
-                                              (* 100 (expt 2 20))))
+                                             (disk-image-size 'guess))
   "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
 derivation).  In the virtual machine, EXP has access to all its inputs from the
 store; it should put its output files in the `/xchg' directory, which is
@@ -118,7 +117,8 @@ runs with MEMORY-SIZE MiB of memory.
 
 When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of type
 DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), of DISK-IMAGE-SIZE bytes and
-return it.
+return it.  When DISK-IMAGE-SIZE is 'guess, estimate the image size based
+based on the size of the closure of REFERENCES-GRAPHS.
 
 When REFERENCES-GRAPHS is true, it must be a list of file name/store path
 pairs, as for `derivation'.  The files containing the reference graphs are
@@ -143,14 +143,18 @@ made available under the /xchg CIFS share."
             (use-modules (guix build utils)
                          (gnu build vm))
 
-            (let ((inputs  '#$(list qemu coreutils))
-                  (linux   (string-append #$linux "/"
-                                          #$(system-linux-image-file-name)))
-                  (initrd  (string-append #$initrd "/initrd"))
-                  (loader  #$loader)
-                  (graphs  '#$(match references-graphs
-                                (((graph-files . _) ...) graph-files)
-                                (_ #f))))
+            (let* ((inputs  '#$(list qemu coreutils))
+                   (linux   (string-append #$linux "/"
+                                           #$(system-linux-image-file-name)))
+                   (initrd  (string-append #$initrd "/initrd"))
+                   (loader  #$loader)
+                   (graphs  '#$(match references-graphs
+                                 (((graph-files . _) ...) graph-files)
+                                 (_ #f)))
+                   (size    #$(if (eq? 'guess disk-image-size)
+                                  #~(+ (* 70 (expt 2 20)) ;ESP
+                                       (estimated-partition-size graphs))
+                                  disk-image-size)))
 
               (set-path-environment-variable "PATH" '("bin") inputs)
 
@@ -160,7 +164,7 @@ made available under the /xchg CIFS share."
                                 #:memory-size #$memory-size
                                 #:make-disk-image? #$make-disk-image?
                                 #:disk-image-format #$disk-image-format
-                                #:disk-image-size #$disk-image-size
+                                #:disk-image-size size
                                 #:references-graphs graphs)))))
 
     (gexp->derivation name builder
@@ -174,7 +178,7 @@ made available under the /xchg CIFS share."
                      (name "qemu-image")
                      (system (%current-system))
                      (qemu qemu-minimal)
-                     (disk-image-size (* 100 (expt 2 20)))
+                     (disk-image-size 'guess)
                      (disk-image-format "qcow2")
                      (file-system-type "ext4")
                      file-system-label
@@ -201,7 +205,8 @@ the image."
                                                    (guix build utils)))
      #~(begin
          (use-modules (gnu build vm)
-                      (guix build utils))
+                      (guix build utils)
+                      (srfi srfi-26))
 
          (let ((inputs
                 '#$(append (list qemu parted e2fsprogs dosfstools)
@@ -227,9 +232,14 @@ the image."
                                #:copy-closures? #$copy-inputs?
                                #:register-closures? #$register-closures?
                                #:system-directory #$os-drv))
+                  (root-size  #$(if (eq? 'guess disk-image-size)
+                                    #~(estimated-partition-size
+                                       (map (cut string-append "/xchg/" <>)
+                                            graphs))
+                                    (- disk-image-size
+                                       (* 50 (expt 2 20)))))
                   (partitions (list (partition
-                                     (size #$(- disk-image-size
-                                                (* 50 (expt 2 20))))
+                                     (size root-size)
                                      (label #$file-system-label)
                                      (file-system #$file-system-type)
                                      (flags '(boot))
diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm
index a296bdf..fe2eb6f 100644
--- a/guix/build/store-copy.scm
+++ b/guix/build/store-copy.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014 Ludovic Courtès <address@hidden>
+;;; Copyright © 2013, 2014, 2017 Ludovic Courtès <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -20,7 +20,9 @@
   #:use-module (guix build utils)
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 ftw)
   #:export (read-reference-graph
+            closure-size
             populate-store))
 
 ;;; Commentary:
@@ -46,6 +48,37 @@ The data at PORT is the format produced by 
#:references-graphs."
            (loop (read-line port)
                  result)))))
 
+(define (file-size file)
+  "Return the size of bytes of FILE, entering it if FILE is a directory."
+  (file-system-fold (const #t)
+                    (lambda (file stat result)    ;leaf
+                      (+ (stat:size stat) result))
+                    (lambda (directory stat result) ;down
+                      (+ (stat:size stat) result))
+                    (lambda (directory stat result) ;up
+                      result)
+                    (lambda (file stat result)    ;skip
+                      result)
+                    (lambda (file stat errno result)
+                      (format (current-error-port)
+                              "file-size: ~a: ~a~%" file
+                              (strerror errno))
+                      result)
+                    0
+                    file
+                    lstat))
+
+(define (closure-size reference-graphs)
+  "Return an estimate of the size of the closure described by
+REFERENCE-GRAPHS, a list of reference-graph files."
+  (define (graph-from-file file)
+    (call-with-input-file file read-reference-graph))
+
+  (define items
+    (delete-duplicates (append-map graph-from-file reference-graphs)))
+
+  (reduce + 0 (map file-size items)))
+
 (define* (populate-store reference-graphs target)
   "Populate the store under directory TARGET with the items specified in
 REFERENCE-GRAPHS, a list of reference-graph files."
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 35675cc..7e20b10 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -854,7 +854,7 @@ Some ACTIONS support additional ARGS.\n"))
     (build-hook? . #t)
     (max-silent-time . 3600)
     (verbosity . 0)
-    (image-size . ,(* 900 (expt 2 20)))
+    (image-size . guess)
     (install-bootloader? . #t)))