replace live-build(7) properties with DISK:DEBIAN-LIVE-ISO-BUILT

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>

2 files changed, 105 insertions, 126 deletions

diff --git a/src/property/disk.lisp b/src/property/disk.lisp
index c2d39f9..dea18f8 100644
--- a/src/property/disk.lisp
+++ b/src/property/disk.lisp
@@ -943,6 +943,111 @@ filesystems will be incrementally updated when other properties change."
        (consfigurator.property.installer:chroot-installed-to-volumes
         ,host ,chroot ,volumes))))
 
+(defprop %squashfsed :posix (chroot image &optional (compression "xz"))
+  (:apply
+   (file:does-not-exist image)
+   (with-remote-temporary-file (excludes)
+     (writefile excludes
+                (format nil "~@{~&~A~}" "/boot" "/proc" "/dev" "/sys" "/run"))
+     (run :inform "nice" "mksquashfs" chroot image
+          "-no-progress" "-comp" compression "-ef" excludes))))
+
+;; Based on live-wrapper, and some help from this guide:
+;;     <https://willhaley.com/blog/custom-debian-live-environment/>
+(defpropspec debian-live-iso-built :lisp (options image-pathname properties)
+  "Build a Debian Live hybrid ISO at IMAGE-PATHNAME for a host with properties
+PROPERTIES, which should specify, at a minimum, the operating system for the
+live system.  OPTIONS is a plist of keyword parameters:
+
+  - :CHROOT-OPTIONS -- passed on to CHROOT:OS-BOOTSTRAPPED-FOR, which see.
+
+Currently only BIOS boot is implemented."
+  (:desc #?"Debian Live ISO built @ ${image-pathname}")
+  (destructuring-bind
+      (&key chroot-options
+       &aux (chroot (image-chroot image-pathname))
+         (iso-root (ensure-directory-pathname
+                    (strcat (unix-namestring image-pathname) ".cd")))
+         (isolinux (merge-pathnames "isolinux/" iso-root))
+         (squashfs (merge-pathnames "live/filesystem.squashfs" iso-root))
+         (host (make-host
+                :hostattrs '(:hostname ("debian"))
+                :propspec
+                (append-propspecs
+                 properties
+                 (make-propspec
+                  :propspec
+                  '(eseqprops
+                    (apt:installed "initramfs-tools" "linux-image-amd64"
+                     "live-boot" "task-laptop" "libnss-myhostname"
+                     "syslinux-common" "isolinux")
+                    (caches-cleaned))))))
+         (host-arch (os:linux-architecture (get-hostattrs-car :os host))))
+      options
+    (unless (member host-arch '(:amd64))
+      (inapplicable-property
+       "Architecture ~A of live host not supported." host-arch))
+    `(eseqprops
+      (apt:installed "squashfs-tools" "xorriso")
+      (file:directory-exists ,isolinux)
+      (file:containing-directory-exists ,squashfs)
+      (on-change (chroot:os-bootstrapped-for ,chroot-options ,chroot ,host)
+
+        (%squashfsed ,chroot ,squashfs)
+
+        ;; Copy the chroot's versions of bootloader binaries.
+        (file:is-copy-of ,(merge-pathnames "isolinux.bin" isolinux)
+                         ,(chroot-pathname "/usr/lib/ISOLINUX/isolinux.bin"
+                                           chroot))
+        ,@(loop for basename in '("ldlinux" "libcom32" "vesamenu" "libutil"
+                                  "libutil" "libmenu" "libgpl" "hdt")
+                for file = (strcat basename ".c32")
+                collect
+                `(file:is-copy-of
+                  ,(merge-pathnames file isolinux)
+                  ,(chroot-pathname
+                    (merge-pathnames file "/usr/lib/syslinux/modules/bios/")
+                    chroot)))
+
+        ;; Copy the targets of the symlinks in the root of the chroot.
+        (file:is-copy-of ,(merge-pathnames "live/vmlinuz" iso-root)
+                         ,(merge-pathnames "vmlinuz" chroot))
+        (file:is-copy-of ,(merge-pathnames "live/initrd.img" iso-root)
+                         ,(merge-pathnames "initrd.img" chroot))
+
+        (file:exists-with-content ,(merge-pathnames "isolinux.cfg" isolinux)
+          ("UI vesamenu.c32"
+           ""
+           "MENU TITLE Live Boot Menu"
+           "DEFAULT linux"
+           "TIMEOUT 600"
+           "MENU RESOLUTION 640 480"
+           ""
+           "LABEL linux"
+           "  MENU LABEL Debian Live [BIOS/ISOLINUX]"
+           "  MENU DEFAULT"
+           "  KERNEL /live/vmlinuz"
+           "  APPEND initrd=/live/initrd.img boot=live"
+           ""
+           "LABEL linux"
+           "  MENU LABEL Debian Live [BIOS/ISOLINUX] (nomodeset)"
+           "  MENU DEFAULT"
+           "  KERNEL /live/vmlinuz"
+           "  APPEND initrd=/live/initrd.img boot=live nomodeset"))
+
+        (cmd:single
+         :inform
+         "xorriso" "-as" "mkisofs" "-iso-level" "3" "-o" ,image-pathname
+         "-full-iso9660-filenames" "-volid" "DEBIAN_LIVE"
+         "-isohybrid-mbr" ,(chroot-pathname "/usr/lib/ISOLINUX/isohdpfx.bin"
+                                            chroot)
+
+         "-eltorito-boot" "isolinux/isolinux.bin"
+         "-no-emul-boot" "-boot-load-size" "4" "-boot-info-table"
+         "--eltorito-catalog" "isolinux/isolinux.cat"
+
+         ,iso-root)))))
+
 (defprop host-volumes-created :lisp ()
   "Recursively create the volumes as specified by DISK:HAS-VOLUMES.
 **THIS PROPERTY UNCONDITIONALLY FORMATS DISKS, POTENTIALLY DESTROYING DATA,
diff --git a/src/property/live-build.lisp b/src/property/live-build.lisp
deleted file mode 100644
index e729234..0000000
--- a/src/property/live-build.lisp
+++ /dev/null
@@ -1,126 +0,0 @@
-;;; Consfigurator -- Lisp declarative configuration management system
-
-;;; Copyright (C) 2021  Sean Whitton <spwhitton@spwhitton.name>
-
-;;; This file is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3, or (at your option)
-;;; any later version.
-
-;;; This file is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;; GNU General Public License for more details.
-
-;;; You should have received a copy of the GNU General Public License
-;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
-
-(in-package :consfigurator.property.live-build)
-(named-readtables:in-readtable :consfigurator)
-
-(defproplist installed :posix ()
-  "Install the Debian Live tool suite.  See live-build(7)."
-  (:desc "Debian Live live-build installed")
-  (os:etypecase
-    (debianlike (apt:installed "live-build"))))
-
-(defun auto/config (config)
-  (with-output-to-string (s)
-    (format s "#!/bin/sh~%lb config noauto")
-    (dolist (argument config)
-      (princ " " s)
-      (princ (escape-sh-token argument) s))
-    (princ " \"${@}\"" s)
-    (terpri s)))
-
-(defprop %lbconfig :posix (dir)
-  (:desc (declare (ignore dir))
-         "lb config")
-  (:apply
-   (with-remote-current-directory (dir)
-     (run :inform "lb" "config"))))
-
-(defprop %lbbootstrap :posix
-    (config-changed dir &aux (chroot (merge-pathnames "chroot/" dir)))
-  (:desc (declare (ignore config-changed chroot))
-         "lb bootstrap")
-  (:hostattrs
-   (declare (ignore config-changed chroot))
-   (os:required 'os:linux))
-  (:check
-   (and (not config-changed)
-        (remote-exists-p chroot)
-        (not (remote-exists-p (merge-pathnames "debootstrap/" chroot)))))
-  (:apply
-   (declare (ignore config-changed))
-   (ignoring-hostattrs (mount:unmounted-below-and-removed chroot))
-   (with-remote-current-directory (dir)
-     (apply #'run :inform
-            (if-let ((proxy (get-hostattrs-car :apt.proxy)))
-              (list :env (list :http_proxy proxy) "lb" "bootstrap")
-              '("lb" "bootstrap"))))))
-
-(defprop %lbchroot :posix (dir)
-  (:desc (declare (ignore dir))
-         "lb chroot")
-  (:apply
-   (with-remote-current-directory (dir)
-     (run "lb" "chroot" "--force"))))
-
-(defprop %lbbinary :posix (dir)
-  (:desc (declare (ignore dir))
-         "lb binary")
-  (:apply
-   (with-remote-current-directory (dir)
-     (run :inform "lb" "binary" "--force"))))
-
-(defpropspec image-built :lisp (config dir properties)
-  "Build an image under DIR using live-build(7), where the resulting live
-system has PROPERTIES, which should contain, at a minimum, a property from
-CONSFIGURATOR.PROPERTY.OS setting the Debian suite and architecture.  CONFIG
-is a list of arguments to pass to lb_config(1), not including the '-a' and
-'-d' options, which Consfigurator will supply based on PROPERTIES.
-
-This property runs the lb_config(1), lb_bootstrap(1), lb_chroot(1) and
-lb_binary(1) commands to build or rebuild the image.  Rebuilding occurs only
-when changes to CONFIG or PROPERTIES mean that the image is potentially
-out-of-date; e.g. if you just add some new items to PROPERTIES then in most
-cases only lb_chroot(1) and lb_binary(1) will be re-run.
-
-Note that lb_chroot(1) and lb_binary(1) both run after applying PROPERTIES,
-and might undo some of their effects.  For example, to configure
-/etc/apt/sources.list, you will need to use CONFIG not PROPERTIES."
-  (:desc (declare (ignore config properties))
-         #?"Debian Live image built in ${dir}")
-  (let* ((dir (ensure-directory-pathname dir))
-         (chroot (merge-pathnames "chroot/" dir))
-         (auto/config (merge-pathnames "auto/config" dir))
-         (clean (mapcar (rcurry #'merge-pathnames
-                                (merge-pathnames "config/" dir))
-                        '("binary" "bootstrap" "chroot" "common" "source")))
-         (host (make-host :propspec properties))
-         (host-os (get-hostattrs-car :os (preprocess-host host))))
-    (when-let ((mirror (get-hostattrs-car :apt.mirror)))
-      (setq config (list* "-m" mirror config)))
-    (setq config (list* "-a" (os:debian-architecture host-os)
-                        "-d" (os:debian-suite host-os) config))
-    `(eseqprops
-      (installed)
-      (file:directory-exists ,(merge-pathnames "auto/" dir))
-      (on-change
-          (eseqprops
-           (on-change
-               (file:has-content ,auto/config ,(auto/config config) :mode #o755)
-             (file:does-not-exist ,@clean)
-             (%lbconfig ,dir)
-             (%lbbootstrap t ,dir))
-           (%lbbootstrap nil ,dir)
-           (deploys ((:chroot :into ,chroot)) ,host))
-        ;; We could run lb_chroot before DEPLOYS, but lb_binary resets things
-        ;; like /etc/apt/sources.list too, so doing that wouldn't avoid the
-        ;; problem that sometimes CONFIG must be used when you'd normally use
-        ;; PROPERTIES.  And we can't really determine whether or not lb_chroot
-        ;; made a change, so it is not good for running inside the first
-        ;; argument to ON-CHANGE.
-        (%lbchroot ,dir)
-        (%lbbinary ,dir)))))