Add non-interactive Fruix installation flow

This commit is contained in:
2026-04-03 23:34:38 +02:00
parent 02a02e365d
commit 2517710282
8 changed files with 980 additions and 68 deletions

View File

@@ -19,13 +19,15 @@ Commands:\n\
System actions:\n\
build Materialize the Fruix system closure in /frx/store.\n\
image Materialize the Fruix disk image in /frx/store.\n\
install Install the Fruix system onto --target PATH.\n\
rootfs Materialize a rootfs tree at --rootfs DIR or ROOTFS-DIR.\n\
\n\
System options:\n\
--system NAME Scheme variable holding the operating-system object.\n\
--store DIR Store directory to use (default: /frx/store).\n\
--disk-capacity SIZE Disk capacity for 'image' (example: 30g).\n\
--root-size SIZE Root filesystem size for 'image' (example: 6g).\n\
--disk-capacity SIZE Disk capacity for 'image' or raw-file 'install' targets.\n\
--root-size SIZE Root filesystem size for 'image' or 'install' (example: 6g).\n\
--target PATH Install target for 'install' (raw image file or /dev/... device).\n\
--rootfs DIR Rootfs target for 'rootfs'.\n\
\n\
Source actions:\n\
@@ -123,6 +125,7 @@ Common options:\n\
(store-dir "/frx/store")
(disk-capacity #f)
(root-size #f)
(target #f)
(rootfs #f))
(match args
(()
@@ -134,33 +137,38 @@ Common options:\n\
(store-dir . ,store-dir)
(disk-capacity . ,disk-capacity)
(root-size . ,root-size)
(target . ,target)
(rootfs . ,rootfs))))
(("--help")
(usage 0))
(((? (lambda (arg) (string-prefix? "--system=" arg)) arg) . tail)
(loop tail positional (option-value arg "--system=") store-dir disk-capacity root-size rootfs))
(loop tail positional (option-value arg "--system=") store-dir disk-capacity root-size target rootfs))
(("--system" value . tail)
(loop tail positional value store-dir disk-capacity root-size rootfs))
(loop tail positional value store-dir disk-capacity root-size target rootfs))
(((? (lambda (arg) (string-prefix? "--store=" arg)) arg) . tail)
(loop tail positional system-name (option-value arg "--store=") disk-capacity root-size rootfs))
(loop tail positional system-name (option-value arg "--store=") disk-capacity root-size target rootfs))
(("--store" value . tail)
(loop tail positional system-name value disk-capacity root-size rootfs))
(loop tail positional system-name value disk-capacity root-size target rootfs))
(((? (lambda (arg) (string-prefix? "--disk-capacity=" arg)) arg) . tail)
(loop tail positional system-name store-dir (option-value arg "--disk-capacity=") root-size rootfs))
(loop tail positional system-name store-dir (option-value arg "--disk-capacity=") root-size target rootfs))
(("--disk-capacity" value . tail)
(loop tail positional system-name store-dir value root-size rootfs))
(loop tail positional system-name store-dir value root-size target rootfs))
(((? (lambda (arg) (string-prefix? "--root-size=" arg)) arg) . tail)
(loop tail positional system-name store-dir disk-capacity (option-value arg "--root-size=") rootfs))
(loop tail positional system-name store-dir disk-capacity (option-value arg "--root-size=") target rootfs))
(("--root-size" value . tail)
(loop tail positional system-name store-dir disk-capacity value rootfs))
(loop tail positional system-name store-dir disk-capacity value target rootfs))
(((? (lambda (arg) (string-prefix? "--target=" arg)) arg) . tail)
(loop tail positional system-name store-dir disk-capacity root-size (option-value arg "--target=") rootfs))
(("--target" value . tail)
(loop tail positional system-name store-dir disk-capacity root-size value rootfs))
(((? (lambda (arg) (string-prefix? "--rootfs=" arg)) arg) . tail)
(loop tail positional system-name store-dir disk-capacity root-size (option-value arg "--rootfs=")))
(loop tail positional system-name store-dir disk-capacity root-size target (option-value arg "--rootfs=")))
(("--rootfs" value . tail)
(loop tail positional system-name store-dir disk-capacity root-size value))
(loop tail positional system-name store-dir disk-capacity root-size target value))
(((? (lambda (arg) (string-prefix? "--" arg)) arg) . _)
(error "unknown option" arg))
((arg . tail)
(loop tail (cons arg positional) system-name store-dir disk-capacity root-size rootfs)))))
(loop tail (cons arg positional) system-name store-dir disk-capacity root-size target rootfs)))))
(define (parse-source-arguments action rest)
(let loop ((args rest)
@@ -276,6 +284,65 @@ Common options:\n\
(generated_file_count . ,(length generated-files))
(reference_count . ,(length references))))))
(define (emit-system-install-metadata os-file resolved-symbol store-dir os result)
(let* ((install-spec (assoc-ref result 'install-spec))
(store-items (assoc-ref result 'store-items))
(host-base-stores (assoc-ref result 'host-base-stores))
(native-base-stores (assoc-ref result 'native-base-stores))
(fruix-runtime-stores (assoc-ref result 'fruix-runtime-stores))
(base (operating-system-freebsd-base os))
(source (freebsd-base-source base))
(host-provenance (call-with-input-file (assoc-ref result 'host-base-provenance-file) read)))
(emit-metadata
`((action . "install")
(os_file . ,os-file)
(system_variable . ,resolved-symbol)
(store_dir . ,store-dir)
(target . ,(assoc-ref result 'target))
(target_kind . ,(assoc-ref result 'target-kind))
(target_device . ,(assoc-ref result 'target-device))
(esp_device . ,(assoc-ref result 'esp-device))
(root_device . ,(assoc-ref result 'root-device))
(install_metadata_path . ,(assoc-ref result 'install-metadata-path))
(freebsd_base_name . ,(freebsd-base-name base))
(freebsd_base_version_label . ,(freebsd-base-version-label base))
(freebsd_base_release . ,(freebsd-base-release base))
(freebsd_base_branch . ,(freebsd-base-branch base))
(freebsd_base_source_root . ,(freebsd-base-source-root base))
(freebsd_base_target . ,(freebsd-base-target base))
(freebsd_base_target_arch . ,(freebsd-base-target-arch base))
(freebsd_base_kernconf . ,(freebsd-base-kernconf base))
(freebsd_base_file . ,(assoc-ref result 'freebsd-base-file))
(freebsd_source_name . ,(freebsd-source-name source))
(freebsd_source_kind . ,(freebsd-source-kind source))
(freebsd_source_url . ,(or (freebsd-source-url source) ""))
(freebsd_source_path . ,(or (freebsd-source-path source) ""))
(freebsd_source_ref . ,(or (freebsd-source-ref source) ""))
(freebsd_source_commit . ,(or (freebsd-source-commit source) ""))
(freebsd_source_sha256 . ,(or (freebsd-source-sha256 source) ""))
(freebsd_source_file . ,(assoc-ref result 'freebsd-source-file))
(freebsd_source_materializations_file . ,(assoc-ref result 'freebsd-source-materializations-file))
(materialized_source_store_count . ,(length (assoc-ref result 'materialized-source-stores)))
(materialized_source_stores . ,(string-join (assoc-ref result 'materialized-source-stores) ","))
(disk_capacity . ,(assoc-ref install-spec 'disk-capacity))
(root_size . ,(assoc-ref install-spec 'root-size))
(efi_size . ,(assoc-ref install-spec 'efi-size))
(closure_path . ,(assoc-ref result 'closure-path))
(host_base_store_count . ,(length host-base-stores))
(host_base_stores . ,(string-join host-base-stores ","))
(native_base_store_count . ,(length native-base-stores))
(native_base_stores . ,(string-join native-base-stores ","))
(fruix_runtime_store_count . ,(length fruix-runtime-stores))
(fruix_runtime_stores . ,(string-join fruix-runtime-stores ","))
(host_base_provenance_file . ,(assoc-ref result 'host-base-provenance-file))
(store_layout_file . ,(assoc-ref result 'store-layout-file))
(host_freebsd_version . ,(assoc-ref host-provenance 'freebsd-version-kru))
(host_uname . ,(assoc-ref host-provenance 'uname))
(usr_src_git_revision . ,(assoc-ref host-provenance 'usr-src-git-revision))
(usr_src_git_branch . ,(assoc-ref host-provenance 'usr-src-git-branch))
(usr_src_newvers_sha256 . ,(assoc-ref host-provenance 'usr-src-newvers-sha256))
(store_item_count . ,(length store-items))))))
(define (emit-system-image-metadata os-file resolved-symbol store-dir os result)
(let* ((image-spec (assoc-ref result 'image-spec))
(store-items (assoc-ref result 'store-items))
@@ -342,14 +409,20 @@ Common options:\n\
(let* ((positional (assoc-ref parsed 'positional))
(disk-capacity (assoc-ref parsed 'disk-capacity))
(root-size (assoc-ref parsed 'root-size))
(target-opt (assoc-ref parsed 'target))
(rootfs-opt (assoc-ref parsed 'rootfs))
(system-name (assoc-ref parsed 'system-name))
(requested-symbol (and system-name (string->symbol system-name))))
(unless (member action '("build" "image" "rootfs"))
(unless (member action '("build" "image" "install" "rootfs"))
(error "unknown system action" action))
(let* ((os-file (match positional
((file . _) file)
(() (error "missing operating-system file argument"))))
(target (or target-opt
(and (string=? action "install")
(match positional
((_ target-path) target-path)
(_ #f)))))
(rootfs (or rootfs-opt
(and (string=? action "rootfs")
(match positional
@@ -398,7 +471,20 @@ Common options:\n\
#:guile-extra-prefix guile-extra-prefix
#:shepherd-prefix shepherd-prefix
#:root-size (or root-size "256m")
#:disk-capacity disk-capacity))))))))))
#:disk-capacity disk-capacity)))
((string=? action "install")
(unless target
(error "install action requires TARGET or --target PATH"))
(emit-system-install-metadata
os-file resolved-symbol store-dir os
(install-operating-system os
#:target target
#:store-dir store-dir
#:guile-prefix guile-prefix
#:guile-extra-prefix guile-extra-prefix
#:shepherd-prefix shepherd-prefix
#:root-size root-size
#:disk-capacity disk-capacity))))))))))
((string=? command "source")
(let* ((positional (assoc-ref parsed 'positional))
(cache-dir (assoc-ref parsed 'cache-dir))