01/02: system: image: Honor image size.

[guix-commits]

mothacehe pushed a commit to branch wip-disk-image
in repository guix.

commit 3abe1b31ec1e747cee47db4e35ba6d30a9bd7998
Author: Mathieu Othacehe <address@hidden>
AuthorDate: Mon Apr 27 13:50:24 2020 +0200

    system: image: Honor image size.
---
 gnu/system/image.scm    | 31 +++++++++++++++++++------------
 guix/scripts/system.scm |  1 +
 2 files changed, 20 insertions(+), 12 deletions(-)

diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index ca63487..9c4209d 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -346,8 +346,17 @@ image ~a {
         "iso9660"
         (partition-file-system (find-root-partition image)))))
 
+(define (root-size image)
+  (let* ((image-size (image-size image))
+         (root-partition (find-root-partition image))
+         (root-size (partition-size root-partition)))
+    (cond
+     ((and (eq? root-size 'guess) image-size)
+      image-size)
+     (else root-size))))
+
 (define* (image-with-os base-image os
-                        #:key uuid)
+                        #:key root-uuid root-size)
   (let*-values (((partitions) (image-partitions base-image))
                 ((root-partition other-partitions)
                  (scm:partition root-partition? partitions)))
@@ -355,16 +364,13 @@ image ~a {
      (inherit base-image)
      (operating-system os)
      (partitions
-      (if uuid
-          (cons (partition
-                 (inherit (car root-partition))
-                 (uuid uuid))
-                other-partitions)
-          partitions)))))
-
-(define* (system-image image
-                       #:key
-                       (substitutable? #t))
+      (cons (partition
+             (inherit (car root-partition))
+             (uuid root-uuid)
+             (size root-size))
+            other-partitions)))))
+
+(define* (system-image image)
   (let* ((image-os (image-operating-system image))
          (format (image-format image))
          (file-systems-to-keep
@@ -400,7 +406,8 @@ image ~a {
                                      (type root-file-system-type))
                                    file-systems-to-keep))))
          (image* (image-with-os image os
-                                #:uuid uuid))
+                                #:root-uuid uuid
+                                #:root-size (root-size image)))
          (register-closures? (has-guix-service-type? os))
          (bootcfg (operating-system-bootcfg os))
          (bootloader (bootloader-configuration-bootloader
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index c59a4b1..1c0bf64 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -700,6 +700,7 @@ checking this by themselves in their 'check' procedure."
        (system-image
         (image
          (inherit image-base)
+         (size image-size)
          (operating-system os)))))
     ((docker-image)
      (system-docker-image os))))