build: Add iso9660 system image generator.

[jackhill/guix/guix.git] / gnu / build / vm.scm

diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 5761976..860c983 100644 (file)
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
 ;;; Copyright © 2016 Leo Famulari <leo@famulari.name>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
@@ -27,6 +27,7 @@
   #:use-module (gnu build linux-boot)
   #:use-module (gnu build install)
   #:use-module (guix records)
+  #:use-module ((guix combinators) #:select (fold2))
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
@@ -46,9 +47,11 @@
             partition-flags
             partition-initializer
 
+            estimated-partition-size
             root-partition-initializer
             initialize-partition-table
-            initialize-hard-disk))
+            initialize-hard-disk
+            make-iso9660-image))
 
 ;;; Commentary:
 ;;;
@@ -71,19 +74,23 @@
                            output
                            (qemu (qemu-command)) (memory-size 512)
                            linux initrd
-                           make-disk-image? (disk-image-size 100)
+                           make-disk-image?
+                           (disk-image-size (* 100 (expt 2 20)))
                            (disk-image-format "qcow2")
                            (references-graphs '()))
   "Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy
 the result to OUTPUT.
 
 When MAKE-DISK-IMAGE? is true, OUTPUT will contain a VM image of
-DISK-IMAGE-SIZE MiB resulting from the execution of BUILDER, which may access
-it via /dev/hda.
+DISK-IMAGE-SIZE bytes resulting from the execution of BUILDER, which may
+access it via /dev/hda.
 
 REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
 the #:references-graphs parameter of 'derivation'."
   (when make-disk-image?
+    (format #t "creating ~a image of ~,2f MiB...~%"
+            disk-image-format (/ disk-image-size (expt 2 20)))
+    (force-output)
     (unless (zero? (system* "qemu-img" "create" "-f" disk-image-format
                             output
                             (number->string disk-image-size)))
@@ -146,17 +153,11 @@ the #:references-graphs parameter of 'derivation'."
   (flags       partition-flags (default '()))
   (initializer partition-initializer (default (const #t))))
 
-(define (fold2 proc seed1 seed2 lst)              ;TODO: factorize
-  "Like `fold', but with a single list and two seeds."
-  (let loop ((result1 seed1)
-             (result2 seed2)
-             (lst     lst))
-    (if (null? lst)
-        (values result1 result2)
-        (call-with-values
-            (lambda () (proc (car lst) result1 result2))
-          (lambda (result1 result2)
-            (loop result1 result2 (cdr lst)))))))
+(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* (initialize-partition-table device partitions
                                      #:key
@@ -192,8 +193,15 @@ actual /dev name based on DEVICE."
                (cons (partition-options head offset index)
                      result))))))
 
-  (format #t "creating partition table with ~a partitions...\n"
-          (length partitions))
+  (format #t "creating partition table with ~a partitions (~a)...\n"
+          (length partitions)
+          (string-join (map (compose (cut string-append <> " MiB")
+                                     number->string
+                                     (lambda (size)
+                                       (round (/ size (expt 2. 20))))
+                                     partition-size)
+                            partitions)
+                       ", "))
   (unless (zero? (apply system* "parted" "--script"
                         device "mklabel" label-type
                         (options partitions offset)))
@@ -344,6 +352,21 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
                             (string-append "boot/grub/grub.cfg=" config-file)))
       (error "failed to create GRUB EFI image"))))
 
+(define* (make-iso9660-image grub config-file os-drv target
+                             #:key (volume-id "GuixSD"))
+  "Given a GRUB package, creates an iso image as TARGET, using CONFIG-FILE as
+Grub configuration and OS-DRV as the stuff in it."
+  (let ((grub-mkrescue (string-append grub "/bin/grub-mkrescue")))
+    (mkdir-p "/tmp/root/var/run")
+    (mkdir-p "/tmp/root/run")
+    (unless (zero? (system* grub-mkrescue "-o" target
+                            (string-append "boot/grub/grub.cfg=" config-file)
+                            (string-append "gnu/store=" os-drv "/..")
+                            "var=/tmp/root/var"
+                            "run=/tmp/root/run"
+                            "--" "-volid" (string-upcase volume-id)))
+      (error "failed to create ISO image"))))
+
 (define* (initialize-hard-disk device
                                #:key
                                bootloader-package