[bug#27521] [PATCH v5] build: Add iso9660 system image generator.

[Danny Milosavljevic <dannym@scratchpost.org>]

* build-aux/hydra/gnu-system.scm (qemu-jobs): Add 'iso9660-image .
* guix/script/system.scm: Add "iso9660-disk-image" action.
* gnu/build/vm.scm (make-iso9660-image): New variable.  Export it.
* gnu/system/vm.scm (iso9660-image): New variable.  Use make-iso9660-image.
(system-disk-image): Use iso9660-image.
---
 build-aux/hydra/gnu-system.scm |  7 ++++
 gnu/build/vm.scm               | 17 ++++++++-
 gnu/system/vm.scm              | 83 +++++++++++++++++++++++++++++++++++-------
 guix/scripts/system.scm        | 20 ++++++----
 4 files changed, 106 insertions(+), 21 deletions(-)

diff --git a/build-aux/hydra/gnu-system.scm b/build-aux/hydra/gnu-system.scm
index eeb7183a4..0b49ce971 100644
--- a/build-aux/hydra/gnu-system.scm
+++ b/build-aux/hydra/gnu-system.scm
@@ -162,6 +162,13 @@ system.")
                        (set-guile-for-build (default-guile))
                        (system-disk-image installation-os
                                           #:disk-image-size
+                                          (* 1024 MiB)))))
+            (->job 'iso9660-image
+                   (run-with-store store
+                     (mbegin %store-monad
+                       (set-guile-for-build (default-guile))
+                       (system-disk-image installation-os
+                                          #:disk-image-size
                                           (* 1024 MiB))))))
       '()))
 
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 57619764c..e930e4c86 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -48,7 +48,8 @@
 
             root-partition-initializer
             initialize-partition-table
-            initialize-hard-disk))
+            initialize-hard-disk
+            make-iso9660-image))
 
 ;;; Commentary:
 ;;;
@@ -344,6 +345,20 @@ 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)
+  "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" "GUIXSD"))
+      (error "failed to create ISO image"))))
+
 (define* (initialize-hard-disk device
                                #:key
                                bootloader-package
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 392737d07..5a865d24b 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -34,6 +34,7 @@
                 #:select (qemu-command))
   #:use-module (gnu packages base)
   #:use-module (gnu packages bootloaders)
+  #:use-module (gnu packages cdrom)
   #:use-module (gnu packages guile)
   #:use-module (gnu packages gawk)
   #:use-module (gnu packages bash)
@@ -170,6 +171,51 @@ made available under the /xchg CIFS share."
                       #:guile-for-build guile-for-build
                       #:references-graphs references-graphs)))
 
+(define* (iso9660-image #:key
+                        (name "iso9660-image")
+                        (system (%current-system))
+                        (qemu qemu-minimal)
+                        os-drv
+                        bootcfg-drv
+                        bootloader
+                        (inputs '()))
+  "Return a bootable, stand-alone iso9660 image.
+
+INPUTS is a list of inputs (as for packages)."
+  (expression->derivation-in-linux-vm
+   name
+   (with-imported-modules (source-module-closure '((gnu build vm)
+                                                   (guix build utils)))
+     #~(begin
+         (use-modules (gnu build vm)
+                      (guix build utils))
+
+         (let ((inputs
+                '#$(append (list qemu parted e2fsprogs dosfstools xorriso)
+                           (map canonical-package
+                                (list sed grep coreutils findutils gawk))))
+
+               ;; This variable is unused but allows us to add INPUTS-TO-COPY
+               ;; as inputs.
+               (to-register
+                '#$(map (match-lambda
+                          ((name thing) thing)
+                          ((name thing output) `(,thing ,output)))
+                        inputs)))
+
+           (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+           (mkdir-p "/tmp")
+           ;(mount "none" "/tmp" "tmpfs")
+           ;(mkdir-p "/tmp/extra")
+           (make-iso9660-image #$(bootloader-package bootloader)
+                               #$bootcfg-drv
+                               #$os-drv
+                               "/xchg/guixsd.iso")
+           (reboot))))
+   #:system system
+   #:make-disk-image? #f
+   #:references-graphs inputs))
+
 (define* (qemu-image #:key
                      (name "qemu-image")
                      (system (%current-system))
@@ -308,19 +354,30 @@ to USB sticks meant to be read-only."
 
     (mlet* %store-monad ((os-drv   (operating-system-derivation os))
                          (bootcfg  (operating-system-bootcfg os)))
-      (qemu-image #:name name
-                  #:os-drv os-drv
-                  #:bootcfg-drv bootcfg
-                  #:bootloader (bootloader-configuration-bootloader
-                                (operating-system-bootloader os))
-                  #:disk-image-size disk-image-size
-                  #:disk-image-format "raw"
-                  #:file-system-type file-system-type
-                  #:file-system-label root-label
-                  #:copy-inputs? #t
-                  #:register-closures? #t
-                  #:inputs `(("system" ,os-drv)
-                             ("bootcfg" ,bootcfg))))))
+      (if (string=? "iso9660" file-system-type)
+          (iso9660-image #:name name
+                         #:os-drv os-drv
+                         #:bootcfg-drv bootcfg
+                         #:bootloader (bootloader-configuration-bootloader
+                                        (operating-system-bootloader os))
+                         #:inputs `(("system" ,os-drv)
+                                    ("bootcfg" ,bootcfg)))
+          (qemu-image #:name name
+                      #:os-drv os-drv
+                      #:bootcfg-drv bootcfg
+                      #:bootloader (bootloader-configuration-bootloader
+                                    (operating-system-bootloader os))
+                      #:disk-image-size disk-image-size
+                      #:disk-image-format "raw"
+                      #:file-system-type (if (string=? "iso9660"
+                                                       file-system-type)
+                                             "ext4"
+                                             file-system-type)
+                      #:file-system-label root-label
+                      #:copy-inputs? #t
+                      #:register-closures? #t
+                      #:inputs `(("system" ,os-drv)
+                                 ("bootcfg" ,bootcfg)))))))
 
 (define* (system-qemu-image os
                             #:key
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 35675cc01..da0f5b04b 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -578,7 +578,9 @@ PATTERN, a string.  When PATTERN is #f, display all the system generations."
                                                 (* 70 (expt 2 20)))
                                             #:mappings mappings))
     ((disk-image)
-     (system-disk-image os #:disk-image-size image-size))))
+     (system-disk-image os #:disk-image-size image-size))
+    ((iso9660-disk-image)
+     (system-disk-image os #:file-system-type "iso9660"))))
 
 (define (maybe-suggest-running-guix-pull)
   "Suggest running 'guix pull' if this has never been done before."
@@ -616,7 +618,8 @@ and TARGET arguments."
   "Perform ACTION for OS.  INSTALL-BOOTLOADER? specifies whether to install
 bootloader; DEVICE is the target devices for bootloader; TARGET is the target
 root directory; IMAGE-SIZE is the size of the image to be built, for the
-'vm-image' and 'disk-image' actions.  FULL-BOOT? is used for the 'vm' action;
+'vm-image', 'iso9660-disk-image' and 'disk-image' actions.
+FULL-BOOT? is used for the 'vm' action;
 it determines whether to boot directly to the kernel or to the bootloader.
 
 When DERIVATIONS-ONLY? is true, print the derivation file name(s) without
@@ -764,6 +767,8 @@ Some ACTIONS support additional ARGS.\n"))
   (display (G_ "\
    init             initialize a root file system to run GNU\n"))
   (display (G_ "\
+   iso9660-disk-image  build a disk image, suitable for a CD or DVD\n"))
+  (display (G_ "\
    extension-graph  emit the service extension graph in Dot format\n"))
   (display (G_ "\
    shepherd-graph   emit the graph of shepherd services in Dot format\n"))
@@ -781,9 +786,9 @@ Some ACTIONS support additional ARGS.\n"))
   (display (G_ "
       --share=SPEC       for 'vm', share host file system according to SPEC"))
   (display (G_ "
-  -r, --root=FILE        for 'vm', 'vm-image', 'disk-image', 'container',
-                         and 'build', make FILE a symlink to the result, and
-                         register it as a garbage collector root"))
+  -r, --root=FILE        for 'vm', 'vm-image', 'disk-image', 'iso9660-disk-image',
+                         'container', and 'build', make FILE a symlink to the
+                         result, and register it as a garbage collector root"))
   (display (G_ "
       --expose=SPEC      for 'vm', expose host file system according to SPEC"))
   (display (G_ "
@@ -957,7 +962,8 @@ argument list and OPTS is the option alist."
         (alist-cons 'argument arg result)
         (let ((action (string->symbol arg)))
           (case action
-            ((build container vm vm-image disk-image reconfigure init
+            ((build container vm vm-image disk-image iso9660-disk-image
+              reconfigure init
               extension-graph shepherd-graph list-generations roll-back
               switch-generation)
              (alist-cons 'action action result))
@@ -987,7 +993,7 @@ argument list and OPTS is the option alist."
         (exit 1))
 
       (case action
-        ((build container vm vm-image disk-image reconfigure)
+        ((build container vm vm-image disk-image iso9660-disk-image reconfigure)
          (unless (= count 1)
            (fail)))
         ((init)