diff --git a/bin/fruix b/bin/fruix index f85cf07..99120dd 100755 --- a/bin/fruix +++ b/bin/fruix @@ -7,6 +7,10 @@ legacy_guile_bin=/tmp/guile-freebsd-validate-install/bin/guile legacy_guile_extra_prefix=/tmp/guile-gnutls-freebsd-validate-install legacy_shepherd_prefix=/tmp/shepherd-freebsd-validate-install legacy_guix_source_dir=$HOME/repos/guix +fruix_channel_url=${FRUIX_CHANNEL_URL:-https://git.teralink.net/self/fruix.git} +script=$project_root/scripts/fruix.scm +modules_dir=$project_root/modules + if [ -x "$builder_root/guile/bin/guile" ]; then default_guile_bin=$builder_root/guile/bin/guile else @@ -27,13 +31,23 @@ if [ -d "$builder_root/src/guix/guix" ]; then else default_guix_source_dir=$legacy_guix_source_dir fi + guix_source_dir=${GUIX_SOURCE_DIR:-$default_guix_source_dir} guile_bin=${GUILE_BIN:-$default_guile_bin} guile_extra_prefix=${GUILE_EXTRA_PREFIX:-$default_guile_extra_prefix} shepherd_prefix=${SHEPHERD_PREFIX:-$default_shepherd_prefix} -fruix_channel_url=${FRUIX_CHANNEL_URL:-https://git.teralink.net/self/fruix.git} -script=$project_root/scripts/fruix.scm -modules_dir=$project_root/modules + +discover_guile_newt_store() +{ + if [ -n "${FRUIX_GUILE_NEWT_STORE:-}" ] && [ -d "$FRUIX_GUILE_NEWT_STORE" ]; then + printf '%s\n' "$FRUIX_GUILE_NEWT_STORE" + return 0 + fi + for path in /frx/store/*-fruix-guile-newt-*; do + [ -d "$path" ] || continue + printf '%s\n' "$path" + done | sort | tail -n 1 +} if [ ! -x "$guile_bin" ]; then echo "Guile binary is not executable: $guile_bin" >&2 @@ -49,21 +63,71 @@ fi guile_prefix=$(CDPATH= cd -- "$(dirname "$guile_bin")/.." && pwd) guile_lib_dir=$guile_prefix/lib +guile_version=$(LD_LIBRARY_PATH="$guile_lib_dir${LD_LIBRARY_PATH:+:$LD_LIBRARY_PATH}" "$guile_bin" -c '(display (effective-version))') +guile_newt_store=$(discover_guile_newt_store || true) +guile_load_path="$modules_dir:$guix_source_dir" +if [ -d "$shepherd_prefix/share/guile/site/$guile_version" ]; then + guile_load_path="$guile_load_path:$shepherd_prefix/share/guile/site/$guile_version" +fi +if [ -d "$guile_extra_prefix/share/guile/site/$guile_version" ]; then + guile_load_path="$guile_load_path:$guile_extra_prefix/share/guile/site/$guile_version" +fi +if [ -n "$guile_newt_store" ] && [ -d "$guile_newt_store/share/guile/site/$guile_version" ]; then + guile_load_path="$guile_load_path:$guile_newt_store/share/guile/site/$guile_version" +fi if [ -n "${GUILE_LOAD_PATH:-}" ]; then - guile_load_path="$modules_dir:$guix_source_dir:$GUILE_LOAD_PATH" -else - guile_load_path="$modules_dir:$guix_source_dir" + guile_load_path="$guile_load_path:$GUILE_LOAD_PATH" +fi + +guile_load_compiled_path= +if [ -d "$shepherd_prefix/lib/guile/$guile_version/site-ccache" ]; then + guile_load_compiled_path="$shepherd_prefix/lib/guile/$guile_version/site-ccache" +fi +if [ -d "$guile_extra_prefix/lib/guile/$guile_version/site-ccache" ]; then + guile_load_compiled_path="${guile_load_compiled_path:+$guile_load_compiled_path:}$guile_extra_prefix/lib/guile/$guile_version/site-ccache" +fi +if [ -n "${GUILE_LOAD_COMPILED_PATH:-}" ]; then + guile_load_compiled_path="${guile_load_compiled_path:+$guile_load_compiled_path:}$GUILE_LOAD_COMPILED_PATH" +fi + +guile_extensions_path= +if [ -d "$guile_extra_prefix/lib/guile/$guile_version/extensions" ]; then + guile_extensions_path="$guile_extra_prefix/lib/guile/$guile_version/extensions" +fi +if [ -n "$guile_newt_store" ] && [ -d "$guile_newt_store/lib/guile/$guile_version/extensions" ]; then + guile_extensions_path="${guile_extensions_path:+$guile_extensions_path:}$guile_newt_store/lib/guile/$guile_version/extensions" +fi +if [ -n "${GUILE_EXTENSIONS_PATH:-}" ]; then + guile_extensions_path="${guile_extensions_path:+$guile_extensions_path:}$GUILE_EXTENSIONS_PATH" +fi + +ld_library_path="$guile_extra_prefix/lib:$guile_lib_dir:/usr/local/lib" +ltdl_library_path="$ld_library_path" +if [ -n "$guile_newt_store" ] && [ -d "$guile_newt_store/lib" ]; then + ld_library_path="$guile_newt_store/lib:$ld_library_path" + ltdl_library_path="$guile_newt_store/lib:$ltdl_library_path" +fi +if [ -n "${LD_LIBRARY_PATH:-}" ]; then + ld_library_path="$ld_library_path:$LD_LIBRARY_PATH" +fi +if [ -n "${LTDL_LIBRARY_PATH:-}" ]; then + ltdl_library_path="$ltdl_library_path:$LTDL_LIBRARY_PATH" fi exec env \ GUILE_AUTO_COMPILE=0 \ GUILE_LOAD_PATH="$guile_load_path" \ - LD_LIBRARY_PATH="$guile_lib_dir${LD_LIBRARY_PATH:+:$LD_LIBRARY_PATH}" \ + GUILE_LOAD_COMPILED_PATH="$guile_load_compiled_path" \ + GUILE_EXTENSIONS_PATH="$guile_extensions_path" \ + LD_LIBRARY_PATH="$ld_library_path" \ + LTDL_LIBRARY_PATH="$ltdl_library_path" \ GUILE_PREFIX="$guile_prefix" \ GUILE_EXTRA_PREFIX="$guile_extra_prefix" \ + GUILE_NEWT_PREFIX="$guile_newt_store" \ SHEPHERD_PREFIX="$shepherd_prefix" \ GUIX_SOURCE_DIR="$guix_source_dir" \ + FRUIX_GUILE_NEWT_STORE="$guile_newt_store" \ FRUIX_PROJECT_ROOT="$project_root" \ FRUIX_CHANNEL_DIR="$project_root" \ FRUIX_CHANNEL_URL="$fruix_channel_url" \ diff --git a/docs/recovery.md b/docs/recovery.md new file mode 100644 index 0000000..b452e08 --- /dev/null +++ b/docs/recovery.md @@ -0,0 +1,70 @@ +What we lost + + Everything below was local-only in fruix and is now gone from the repo checkout. + + ### 1. Newt runtime integration on real FreeBSD + + Lost code/work around: + - guile-newt runtime integration into Fruix + - auto-discovery of prepared guile-newt from bin/fruix + - threading Newt runtime into installer artifacts + - installed wrapper env support for Newt + - LTDL_LIBRARY_PATH handling + - installer-only shared-lib exposure under /usr/local/lib + + ### 2. Installer frontend self-test and launcher split + + Lost: + - run-newt-self-test + - --self-test CLI support for installer-tui + - headless tmux-based TUI smoke harness + - installer media launcher split into: + - dispatcher + - backend apply engine + - rc.d frontend-selection knobs + - headless installer-media self-test harness + - XCP-ng installer-media self-test harness + + ### 3. Real XCP-ng validation of the booted installer frontend + + Lost from repo: + - the actual harness/scripts/docs for the successful XCP-ng self-test run + - all code fixes uncovered by that run: + - termcap exposure + - metadata cleaning fix + - Newt media runtime fixes + - frontend dispatch behavior + + ### 4. Installed system console/default tty work + + Lost: + - declarative console-configuration model + - sane default dual console policy + - default gettys on: + - ttyv0..ttyv7 + - ttyu0 + - xc0 + - freebsd-userland additions needed for real login/getty behavior + - getty + - login + - passwd + - su + - who + - last + - nologin + - /etc/gettytab exposure into installed rootfs + - QEMU and XCP-ng validation scripts/reports for console defaults + + ### 5. The package CLI and dev-tool package work + + Lost: + - fruix package list/search/show/build + - package lookup helpers + - added package defs for: + - freebsd-ripgrep + - freebsd-tmux + - freebsd-nodejs + - freebsd-npm + - freebsd-neovim + + This part was not committed yet. diff --git a/docs/recovery_2.md b/docs/recovery_2.md new file mode 100644 index 0000000..ae669b5 --- /dev/null +++ b/docs/recovery_2.md @@ -0,0 +1,189 @@ +Yes — there are useful recovery artifacts, especially in /tmp and /frx/store. + + Best stuff I found + + ### 1. Generated shell scripts in /tmp + + These are very helpful because they capture the rendered output of lost Scheme code. + + Especially: + + - /tmp/fruix-installer-run.sh + - /tmp/fruix-installer-apply.sh + - /tmp/fruix-installer-rc.sh + - /tmp/fruix-installed-fruix.sh + + Those are gold for reconstructing: + + - installer launcher/dispatcher behavior + - self-test flow + - frontend/apply split + - installed wrapper behavior + - Newt-related environment wiring + + Example: /tmp/fruix-installed-fruix.sh still clearly contains: + - build-base + - deploy + - installer-tui + - GUILE_NEWT_PREFIX + - FRUIX_GUILE_NEWT_STORE + - LTDL_LIBRARY_PATH + + So a lot of the lost render.scm work is still recoverable from there. + + ──────────────────────────────────────────────────────────────────────────────── + + ### 2. Validation workdirs in /tmp + + There are lots of preserved run directories. + + Most valuable: + + #### Installer media / Newt / XCP-ng + + - /tmp/current-installer-media-self-test-xcpng-pass3 + - /tmp/current-installer-media-self-test-xcpng-debug* + - /tmp/current-installer-media-self-test-xcpng-fix* + + These contain: + - metadata + - debug logs + - generated declarations + - installer outputs + + Key file: + - /tmp/current-installer-media-self-test-xcpng-pass3/installer-media-self-test-xcpng-metadata.txt + + That preserves the successful real validation result. + + #### Installed console defaults + + - /tmp/current-installed-console-defaults-qemu3 + - /tmp/current-installed-console-defaults-xcpng3 + + These contain: + - generated declarations + - metadata proving the getty/default-console behavior + + Key file: + - /tmp/current-installed-console-defaults-xcpng3/installed-console-defaults-xcpng-metadata.txt + + That preserves the successful real XCP-ng console-default validation. + + ──────────────────────────────────────────────────────────────────────────────── + + ### 3. Package build outputs are still in /frx/store + + The package work is not in git anymore, but the built package outputs still exist: + + - /frx/store/0d75ed1b2220ced7766a72ff72f0908d8683d2e6-freebsd-ripgrep-15.1.0_4 + - /frx/store/4e91ae1c446a61f5056165c73db0a0018378dbe9-freebsd-tmux-3.6a + - /frx/store/9484fd141436bc6e0d6fa19a7a14a360ece3be42-freebsd-nodejs-24.14.0_2 + - /frx/store/a445350b103e45a6841045bb190e50063edfe6a8-freebsd-npm-11.11.0 + - /frx/store/21da570210730ef32025c4010eca138a37b53dc6-freebsd-neovim-0.12.0 + + And importantly, their manifests are still there: + + - .../.fruix-package + + Those manifests preserve enough to reconstruct package definitions pretty well: + - package name + - version + - build system + - input store paths + - install-plan signatures + + So the package work is not fully lost. + + ──────────────────────────────────────────────────────────────────────────────── + + ### 4. Relevant system closures are still in /frx/store + + Useful recovery closures include: + + #### Console-default system closures + + - /frx/store/8f615a0413ec2ad8596055e18b69795e9d37a2f3-fruix-system-fruix-console-defaults + - plus older variants + + These preserve: + - /etc/ttys + - /boot/loader.conf + - generated installed Fruix wrapper + - actual realized output of the lost console/default logic + + #### Installer / Newt closures and ISOs + + - /frx/store/1616e555f705ae2f6be8a7c671d382afa5346535-fruix-guile-newt-0.0.3 + - various fruix-system-fruix-installer-self-test* + - various fruix-installer-iso-fruix-installer-self-test-installer + + Those preserve the actual built results of the lost integration work. + + ──────────────────────────────────────────────────────────────────────────────── + + Less useful, but still maybe helpful + + ### /var/tmp + + I only found one notable thing: + + - /var/tmp/fruix-freebsd-native-build-f2b94d7bfd1feb56a1c597f15a3a2d527653d5571f7a9dc50c47f94cf9758db8 + + This looks like native-build staging/log output. + Useful for native-base archaeology, but not the main recovery source for the lost installer/package work. + + ──────────────────────────────────────────────────────────────────────────────── + + What I did not find + + I do not currently see: + - another full up-to-date checkout + - another git repo with the lost commits + - an obvious source backup of the lost modules/... files + - hidden extra git objects preserving the lost local commits + + So this is not a simple “recover the repo” situation. + + ──────────────────────────────────────────────────────────────────────────────── + + Best recovery sources now + + If we want to reconstruct efficiently, I’d prioritize: + + ### Source reconstruction from /tmp + + - /tmp/fruix-installed-fruix.sh + - /tmp/fruix-installer-run.sh + - /tmp/fruix-installer-apply.sh + - /tmp/fruix-installer-rc.sh + + ### Behavioral truth from /frx/store + + - console-default system closure(s) + - installer self-test closure(s) + - package outputs + .fruix-package + + ### Validation truth from /tmp/current-* + + - current-installer-media-self-test-xcpng-pass3 + - current-installed-console-defaults-qemu3 + - current-installed-console-defaults-xcpng3 + + ──────────────────────────────────────────────────────────────────────────────── + + My recommendation + + Yes, these are worth preserving immediately before we do anything else. + + I’d suggest we first copy/tar: + - the key /tmp workdirs and generated scripts + - the relevant /frx/store paths list + - maybe the one /var/tmp/fruix-freebsd-native-build-* dir + + That would give us a solid recovery bundle. + + If you want, I can do exactly that next: + 1. collect the useful artifacts into a rescue directory + 2. write an inventory file + 3. then start reconstructing the lost code from them. diff --git a/modules/fruix/installer.scm b/modules/fruix/installer.scm index 4ebd318..57d4467 100644 --- a/modules/fruix/installer.scm +++ b/modules/fruix/installer.scm @@ -1,6 +1,7 @@ (define-module (fruix installer) #:use-module (fruix installer state) #:use-module (fruix installer steps) + #:use-module (fruix installer flow) #:use-module (fruix installer final) #:use-module (fruix installer newt) #:re-export (default-installer-network-mode @@ -35,8 +36,13 @@ next-installer-step-id previous-installer-step-id validate-installer-state-for-step + installer-network-mode-options + installer-target-device-candidates + installer-command-apply + run-installer-command-script installer-final-summary-text newt-required-bindings missing-newt-bindings newt-available? + run-newt-self-test run-newt-installer)) diff --git a/modules/fruix/installer/final.scm b/modules/fruix/installer/final.scm index dfc48a6..9367e18 100644 --- a/modules/fruix/installer/final.scm +++ b/modules/fruix/installer/final.scm @@ -22,5 +22,5 @@ (format #f "current step: ~a\n\n" (installer-state-selected-step state)) layout-summary "\n\n" - "This prototype only validates the installer state and presents a Newt-based\n" - "review flow. It does not yet invoke the final install action from the TUI.\n"))) + "Selecting Install in the TUI hands control back to the Fruix installer\n" + "engine, which then applies the shared storage/install backend.\n"))) diff --git a/modules/fruix/installer/flow.scm b/modules/fruix/installer/flow.scm new file mode 100644 index 0000000..71f3ebc --- /dev/null +++ b/modules/fruix/installer/flow.scm @@ -0,0 +1,140 @@ +(define-module (fruix installer flow) + #:use-module (fruix installer state) + #:use-module (fruix installer steps) + #:use-module (fruix system storage) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-13) + #:export (installer-network-mode-options + installer-target-device-candidates + installer-command-apply + run-installer-command-script)) + +(define installer-network-mode-options + '(none dhcp)) + +(define invalid-target-device-prefixes + '("cd" "md" "pass" "ses" "fd" "ugen" "lo" "pflog" "tap" "tun")) + +(define (target-device-name-candidate? name) + (and (non-empty-string? name) + (not (any (lambda (prefix) + (string-prefix? prefix name)) + invalid-target-device-prefixes)))) + +(define (normalize-target-device value) + (cond + ((not (non-empty-string? value)) #f) + ((string-prefix? "/dev/" value) value) + (else (string-append "/dev/" value)))) + +(define* (installer-target-device-candidates state #:key kern-disks) + (let* ((explicit-target (normalize-target-device (installer-state-target-device state))) + (discovered (if kern-disks + (string-tokenize kern-disks) + '())) + (devices (append (if explicit-target (list explicit-target) '()) + (map (lambda (name) + (string-append "/dev/" name)) + (filter target-device-name-candidate? discovered))))) + (delete-duplicates devices string=?))) + +(define (step-transition state next-step) + (installer-state-update state #:selected-step next-step)) + +(define (command-success state result target-devices) + `((state . ,state) + (result . ,result) + (target-devices . ,target-devices))) + +(define (update-state-field state field value) + (match field + ('storage-layout (installer-state-update state #:storage-layout value)) + ('target-device (installer-state-update state #:target-device (normalize-target-device value))) + ('host-name (installer-state-update state #:host-name value)) + ('root-size (installer-state-update state #:root-size value)) + ('disk-capacity (installer-state-update state #:disk-capacity value)) + ('network-mode (installer-state-update state #:network-mode value)) + ('selected-step (installer-state-update state #:selected-step value)) + ('metadata (installer-state-update state #:metadata value)) + (_ + (error "unsupported installer state field" field)))) + +(define* (installer-command-apply state command #:key target-devices) + (let ((target-devices (or target-devices + (installer-target-device-candidates state)))) + (catch #t + (lambda () + (match command + (('set field value) + (command-success (update-state-field state field value) + 'continue + target-devices)) + (('action 'next) + (let* ((current (installer-state-selected-step state)) + (_ (validate-installer-state-for-step state current)) + (next (next-installer-step-id current))) + (command-success (if next + (step-transition state next) + state) + 'continue + target-devices))) + (('action 'back) + (let ((prev (previous-installer-step-id (installer-state-selected-step state)))) + (command-success (if prev + (step-transition state prev) + state) + 'continue + target-devices))) + (('action 'proceed) + (let* ((current (installer-state-selected-step state)) + (_ (unless (memq current '(summary install)) + (error "installer proceed is only valid from summary/install" current state))) + (_ (validate-installer-state-for-step state 'install)) + (final-state (step-transition state 'install))) + (command-success final-state 'proceed target-devices))) + (('action 'abort) + (command-success state 'abort target-devices)) + (('action 'goto step-id) + (unless (find-installer-step step-id) + (error "unknown installer step" step-id)) + (command-success (step-transition state step-id) + 'continue + target-devices)) + (_ + (error "unsupported installer command" command)))) + (lambda args + `((state . ,state) + (result . error) + (error . ,args) + (target-devices . ,target-devices)))))) + +(define* (run-installer-command-script state commands #:key target-devices) + (let loop ((state state) + (pending commands) + (transcript '())) + (if (null? pending) + `((state . ,state) + (result . completed) + (transcript . ,(reverse transcript)) + (target-devices . ,(or target-devices + (installer-target-device-candidates state)))) + (let* ((command (car pending)) + (response (installer-command-apply state command + #:target-devices target-devices)) + (next-state (assoc-ref response 'state)) + (result (assoc-ref response 'result)) + (entry `((command . ,command) + (result . ,result) + (selected-step . ,(installer-state-selected-step next-state)) + (state . ,(installer-state-spec next-state)) + (error . ,(or (assoc-ref response 'error) #f))))) + (if (eq? result 'continue) + (loop next-state + (cdr pending) + (cons entry transcript)) + `((state . ,next-state) + (result . ,result) + (transcript . ,(reverse (cons entry transcript))) + (error . ,(or (assoc-ref response 'error) #f)) + (target-devices . ,(assoc-ref response 'target-devices)))))))) diff --git a/modules/fruix/installer/newt.scm b/modules/fruix/installer/newt.scm index 0fca249..942883c 100644 --- a/modules/fruix/installer/newt.scm +++ b/modules/fruix/installer/newt.scm @@ -1,11 +1,18 @@ (define-module (fruix installer newt) #:use-module (fruix installer final) + #:use-module (fruix installer flow) #:use-module (fruix installer state) #:use-module (fruix installer steps) + #:use-module (fruix system storage) #:use-module (ice-9 match) + #:use-module (ice-9 popen) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-13) #:export (newt-required-bindings missing-newt-bindings newt-available? + run-newt-self-test run-newt-installer)) (define newt-required-bindings @@ -13,7 +20,25 @@ newt-finish clear-screen message-window - choice-window)) + choice-window + make-centered-window + pop-window + make-form + add-components-to-form + set-current-component + run-form + destroy-form + make-button + make-label + make-textbox + set-textbox-text + make-entry + entry-value + make-radio-button + current-radio-button + components=? + FLAG-BORDER + FLAG-SCROLL)) (define (newt-interface) (false-if-exception (resolve-interface '(newt)))) @@ -32,44 +57,424 @@ (define (newt-available?) (null? (missing-newt-bindings))) -(define (call-newt name . args) - (let ((proc (newt-binding name))) - (unless proc +(define (newt-ref name) + (let ((value (newt-binding name))) + (unless value (error "missing required Newt binding" name)) + value)) + +(define (call-newt name . args) + (let ((proc (newt-ref name))) (apply proc args))) +(define (render-error args) + (match args + ((_ message . _) (if (string? message) + message + (call-with-output-string + (lambda (port) + (write args port))))) + (_ + (call-with-output-string + (lambda (port) + (write args port)))))) + +(define (state-fields state steps) + `((state . ,(installer-state-spec state)) + (step-count . ,(length steps)) + (step-ids . ,(map installer-step-id steps)))) + +(define (newt-result state mode available? result error missing steps) + (append `((ui . newt) + (mode . ,mode) + (available? . ,available?) + (result . ,result) + (error . ,error) + (missing-bindings . ,missing)) + (state-fields state steps))) + +(define (show-error-page title text) + (call-newt 'message-window title "OK" text) + 'ok) + +(define (button-x-position count index) + (cond + ((= count 1) 30) + ((= count 2) (list-ref '(20 42) index)) + ((= count 3) (list-ref '(8 30 52) index)) + (else (+ 4 (* index 14))))) + +(define (make-buttons button-specs y) + (let ((count (length button-specs))) + (let loop ((rest button-specs) + (index 0) + (result '())) + (match rest + (() (reverse result)) + ((spec . tail) + (loop tail + (+ index 1) + (cons (cons (car spec) + (call-newt 'make-button + (button-x-position count index) + y + (cdr spec))) + result))))))) + +(define (button-action buttons component) + (let ((match-entry (find (lambda (entry) + (call-newt 'components=? (cdr entry) component)) + buttons))) + (and match-entry (car match-entry)))) + +(define (run-form-page title width height components focus buttons) + (let ((form (call-newt 'make-form))) + (dynamic-wind + (lambda () + (call-newt 'make-centered-window width height title)) + (lambda () + (apply call-newt (append (list 'add-components-to-form form) components)) + (when focus + (call-newt 'set-current-component form focus)) + (let loop () + (call-with-values (lambda () + (call-newt 'run-form form)) + (lambda (reason payload) + (match reason + ('exit-component + (or (button-action buttons payload) + (loop))) + (_ + (loop))))))) + (lambda () + (false-if-exception + (call-newt 'destroy-form form)) + (false-if-exception + (call-newt 'pop-window)))))) + +(define* (run-text-page title info-text button-specs + #:key + (width 72) + (height 16) + (textbox-height 8)) + (let* ((textbox (call-newt 'make-textbox 2 1 66 textbox-height + (+ (newt-ref 'FLAG-BORDER) + (newt-ref 'FLAG-SCROLL)))) + (_ (call-newt 'set-textbox-text textbox info-text)) + (buttons (make-buttons button-specs (- height 3)))) + (run-form-page title width height + (append (list textbox) (map cdr buttons)) + (cdr (car buttons)) + buttons))) + +(define* (run-entry-page title info-text field-label initial-value button-specs + #:key + (width 72) + (height 16)) + (let* ((textbox (call-newt 'make-textbox 2 1 66 4 + (+ (newt-ref 'FLAG-BORDER) + (newt-ref 'FLAG-SCROLL)))) + (_ (call-newt 'set-textbox-text textbox info-text)) + (label (call-newt 'make-label 2 7 field-label)) + (entry (call-newt 'make-entry 2 8 66 #:initial-value (or initial-value ""))) + (buttons (make-buttons button-specs (- height 3))) + (action (run-form-page title width height + (append (list textbox label entry) (map cdr buttons)) + entry + buttons))) + `((action . ,action) + (value . ,(call-newt 'entry-value entry))))) + +(define* (run-radio-page title info-text items current-value button-specs + #:key + (width 72) + (height 18)) + (if (null? items) + '((action . abort) (value . #f)) + (let* ((textbox (call-newt 'make-textbox 2 1 66 4 + (+ (newt-ref 'FLAG-BORDER) + (newt-ref 'FLAG-SCROLL)))) + (_ (call-newt 'set-textbox-text textbox info-text)) + (radios + (let loop ((rest items) + (index 0) + (previous #f) + (result '())) + (match rest + (() (reverse result)) + (((value . text) . tail) + (let* ((radio (if previous + (call-newt 'make-radio-button 4 (+ 6 index) text + (and current-value (equal? value current-value)) + previous) + (call-newt 'make-radio-button 4 (+ 6 index) text + (and current-value (equal? value current-value)))))) + (loop tail + (+ index 1) + radio + (cons (cons value radio) result))))))) + (focus (cdar radios)) + (buttons (make-buttons button-specs (- height 3))) + (action (run-form-page title width height + (append (list textbox) + (map cdr radios) + (map cdr buttons)) + focus + buttons)) + (selected-radio (call-newt 'current-radio-button focus)) + (selected-entry (find (lambda (entry) + (call-newt 'components=? (cdr entry) selected-radio)) + radios))) + `((action . ,action) + (value . ,(and selected-entry (car selected-entry))))))) + +(define (apply-installer-commands state commands target-devices) + (let loop ((current-state state) + (pending commands)) + (if (null? pending) + `((state . ,current-state) + (result . continue) + (target-devices . ,target-devices)) + (let* ((response (installer-command-apply current-state + (car pending) + #:target-devices target-devices)) + (result (assoc-ref response 'result)) + (next-state (assoc-ref response 'state))) + (if (and (eq? result 'continue) + (pair? (cdr pending))) + (loop next-state (cdr pending)) + response))))) + +(define (handle-page-response state commands target-devices) + (let ((response (apply-installer-commands state commands target-devices))) + (if (eq? (assoc-ref response 'result) 'error) + (begin + (show-error-page "Installer validation error" + (render-error (assoc-ref response 'error))) + `((state . ,(assoc-ref response 'state)) + (result . retry))) + response))) + +(define (welcome-text) + (string-append + "Welcome to the Fruix installer.\n\n" + "This first interactive installer guides you through target disk selection,\n" + "review of the default GPT + EFI + UFS storage layout, hostname setup,\n" + "and a minimal network policy before handing control back to the installer\n" + "engine to apply the plan.")) + +(define (storage-layout-text state) + (let ((layout (installer-state-effective-storage-layout state))) + (string-append + "The default Fruix v1 layout uses a single GPT disk with an EFI system\n" + "partition and a UFS root filesystem.\n\n" + (if layout + (render-storage-layout-summary layout) + "storage-layout ")))) + +(define (network-mode-text mode) + (case mode + ((dhcp) "Use DHCP when networking is needed during installation") + (else "Do not make installer networking changes"))) + +(define (run-welcome-page state) + (let ((action (run-text-page "Fruix installer" (welcome-text) + '((next . "Continue") + (abort . "Abort")) + #:height 15 + #:textbox-height 7))) + (case action + ((next) (handle-page-response state '((action next)) '())) + (else `((state . ,state) (result . abort)))))) + +(define (read-kern-disks) + (false-if-exception + (let ((port (open-pipe* OPEN_READ "sysctl" "-n" "kern.disks"))) + (let ((text (get-string-all port))) + (close-pipe port) + text)))) + +(define (run-target-disk-page state) + (let* ((target-devices (installer-target-device-candidates state #:kern-disks (or (read-kern-disks) ""))) + (items (map (lambda (device) + (cons device device)) + target-devices))) + (if (null? items) + (begin + (show-error-page "No install target disks" + "No suitable target disks were discovered. Re-run the installer with --install-target-device /dev/NAME or boot inside the installer environment.") + `((state . ,state) (result . abort))) + (let* ((response (run-radio-page "Target disk" + "Choose the disk that Fruix should overwrite and install to. The selected disk will be repartitioned." + items + (or (installer-state-target-device state) + (caar items)) + '((back . "Back") + (next . "Next") + (abort . "Abort")))) + (action (assoc-ref response 'action)) + (value (assoc-ref response 'value))) + (case action + ((back) (handle-page-response state '((action back)) target-devices)) + ((next) (handle-page-response state + `((set target-device ,value) + (action next)) + target-devices)) + (else `((state . ,state) (result . abort)))))))) + +(define (run-storage-layout-page state) + (let ((action (run-text-page "Storage layout" + (storage-layout-text state) + '((back . "Back") + (next . "Next") + (abort . "Abort")) + #:height 18 + #:textbox-height 11))) + (case action + ((back) (handle-page-response state '((action back)) '())) + ((next) (handle-page-response state '((action next)) '())) + (else `((state . ,state) (result . abort)))))) + +(define (run-hostname-page state) + (let* ((response (run-entry-page "Hostname" + "Choose the hostname that the installed Fruix system should use on first boot." + "Host name" + (installer-state-host-name state) + '((back . "Back") + (next . "Next") + (abort . "Abort")))) + (action (assoc-ref response 'action)) + (value (string-trim-both (assoc-ref response 'value)))) + (case action + ((back) (handle-page-response state '((action back)) '())) + ((next) (handle-page-response state + `((set host-name ,value) + (action next)) + '())) + (else `((state . ,state) (result . abort)))))) + +(define (run-network-page state) + (let* ((items '((none . "No installer networking changes") + (dhcp . "Use wired DHCP when networking is needed"))) + (response (run-radio-page "Network" + "Choose the simple installer networking policy. Fruix keeps the first interactive installer deliberately small and wired-first." + items + (installer-state-network-mode state) + '((back . "Back") + (next . "Next") + (abort . "Abort")))) + (action (assoc-ref response 'action)) + (value (assoc-ref response 'value))) + (case action + ((back) (handle-page-response state '((action back)) '())) + ((next) (handle-page-response state + `((set network-mode ,value) + (action next)) + '())) + (else `((state . ,state) (result . abort)))))) + +(define (run-summary-page state) + (let* ((summary-text + (string-append + (installer-final-summary-text state) + "\n" + (format #f "network policy: ~a\n" (network-mode-text (installer-state-network-mode state))) + "\nSelect Install to hand control back to the Fruix installer engine.\n" + "The engine will apply the shared storage/install backend outside this UI.")) + (action (run-text-page "Review and install" + summary-text + '((back . "Back") + (proceed . "Install") + (abort . "Abort")) + #:height 20 + #:textbox-height 13))) + (case action + ((back) (handle-page-response state '((action back)) '())) + ((proceed) (handle-page-response state '((action proceed)) '())) + (else `((state . ,state) (result . abort)))))) + +(define* (run-newt-self-test #:key (steps %default-installer-steps)) + (let ((missing (missing-newt-bindings))) + (if (pair? missing) + `((ui . newt) + (mode . self-test) + (available? . #f) + (result . unavailable) + (error . #f) + (missing-bindings . ,missing) + (step-count . ,(length steps)) + (step-ids . ,(map installer-step-id steps))) + (catch #t + (lambda () + (dynamic-wind + (lambda () + (call-newt 'newt-init) + (call-newt 'clear-screen)) + (lambda () + `((ui . newt) + (mode . self-test) + (available? . #t) + (result . self-test-ok) + (error . #f) + (missing-bindings . ()) + (step-count . ,(length steps)) + (step-ids . ,(map installer-step-id steps)))) + (lambda () + (false-if-exception + (call-newt 'newt-finish))))) + (lambda args + `((ui . newt) + (mode . self-test) + (available? . #t) + (result . error) + (error . ,args) + (missing-bindings . ()) + (step-count . ,(length steps)) + (step-ids . ,(map installer-step-id steps)))))))) + (define* (run-newt-installer state #:key (steps %default-installer-steps)) (let ((missing (missing-newt-bindings))) (if (pair? missing) - `((ui . newt) - (available? . #f) - (missing-bindings . ,missing) - (result . unavailable) - (state . ,(installer-state-spec state)) - (step-count . ,(length steps)) - (step-ids . ,(map installer-step-id steps))) - (dynamic-wind + (newt-result state 'interactive #f 'unavailable #f missing steps) + (catch #t (lambda () - (call-newt 'newt-init) - (call-newt 'clear-screen)) - (lambda () - (call-newt 'message-window - "Fruix installer" - "Continue" - (installer-state-summary state)) - (let ((result (call-newt 'choice-window - "Fruix installer review" - "Proceed" - "Abort" - (installer-final-summary-text state)))) - `((ui . newt) - (available? . #t) - (result . ,(match result - (1 'proceed) - (2 'abort) - (_ 'unknown))) - (state . ,(installer-state-spec state)) - (step-count . ,(length steps)) - (step-ids . ,(map installer-step-id steps))))) - (lambda () - (call-newt 'newt-finish)))))) + (dynamic-wind + (lambda () + (call-newt 'newt-init) + (call-newt 'clear-screen)) + (lambda () + (let loop ((current-state state)) + (let* ((step-id (installer-state-selected-step current-state)) + (response (case step-id + ((welcome) (run-welcome-page current-state)) + ((target-disk) (run-target-disk-page current-state)) + ((storage-layout) (run-storage-layout-page current-state)) + ((hostname) (run-hostname-page current-state)) + ((network) (run-network-page current-state)) + ((summary install complete) (run-summary-page current-state)) + (else + `((state . ,current-state) + (result . error) + (error . (unknown-step ,step-id)))))) + (result (assoc-ref response 'result)) + (next-state (assoc-ref response 'state))) + (case result + ((continue retry) + (loop next-state)) + ((proceed abort) + (newt-result next-state 'interactive #t result #f '() steps)) + ((error) + (newt-result next-state 'interactive #t 'error + (assoc-ref response 'error) + '() + steps)) + (else + (newt-result next-state 'interactive #t 'error + `(unexpected-result ,result) + '() + steps)))))) + (lambda () + (false-if-exception + (call-newt 'newt-finish))))) + (lambda args + (newt-result state 'interactive #t 'error args '() steps)))))) diff --git a/modules/fruix/system/freebsd/media.scm b/modules/fruix/system/freebsd/media.scm index 2cf4e27..e2e0c3a 100644 --- a/modules/fruix/system/freebsd/media.scm +++ b/modules/fruix/system/freebsd/media.scm @@ -68,6 +68,18 @@ '() table)) +(define (discover-fruix-runtime-store store-dir name-fragment) + (and store-dir + (file-exists? store-dir) + (let ((matches + (sort (filter (lambda (entry) + (and (not (member entry '("." ".."))) + (string-contains entry name-fragment) + (file-is-directory? (string-append store-dir "/" entry)))) + (directory-entries store-dir)) + stringstring realized-storage-layout)) (chmod (string-append install-root "/realized-storage-layout.scm") #o644)))) -(define (render-installer-run-script store-dir plan-directory) +(define (render-installer-apply-script store-dir plan-directory) (let ((target-rootfs (string-append plan-directory "/target-rootfs")) (store-items-file (string-append plan-directory "/store-items")) (install-metadata-source (string-append plan-directory "/install.scm")) @@ -855,6 +884,198 @@ "echo 'fruix-installer:done'\n" "write_state done\n"))) +(define (render-installer-run-script store-dir plan-directory) + (let ((state-file (string-append plan-directory "/state")) + (dispatcher-log-file "/var/log/fruix-installer-dispatch.log") + (apply-script "/usr/local/libexec/fruix-installer-apply") + (tui-transcript (string-append plan-directory "/installer-tui.typescript")) + (tui-metadata-file (string-append plan-directory "/installer-tui-metadata.txt"))) + (string-append + "#!/bin/sh\n" + "set -eu\n" + "PATH=/sbin:/bin:/usr/sbin:/usr/bin:/usr/local/sbin:/usr/local/bin\n" + "umask 022\n" + "state_file='" state-file "'\n" + "dispatcher_log_file='" dispatcher-log-file "'\n" + "apply_script='" apply-script "'\n" + "tui_transcript='" tui-transcript "'\n" + "tui_metadata_file='" tui-metadata-file "'\n" + "frontend=${FRUIX_INSTALLER_FRONTEND:-auto}\n" + "installer_term=${FRUIX_INSTALLER_TERM:-xterm}\n" + "write_state()\n" + "{\n" + " mkdir -p \"$(dirname \"$state_file\")\"\n" + " printf '%s\\n' \"$1\" >\"$state_file\"\n" + "}\n" + "log()\n" + "{\n" + " mkdir -p \"$(dirname \"$dispatcher_log_file\")\"\n" + " printf '%s %s\\n' \"$(date -u +%Y-%m-%dT%H:%M:%SZ)\" \"$*\" >>\"$dispatcher_log_file\"\n" + "}\n" + "clean_tui_metadata()\n" + "{\n" + " source=$1\n" + " destination=$2\n" + " [ -f \"$source\" ] || return 1\n" + " tr -d '\\15' < \"$source\" | tr -cd '\\11\\12\\40-\\176' | awk 'match($0, /[a-z_][a-z_]*=.*/){print substr($0, RSTART)}' > \"$destination\"\n" + "}\n" + "metadata_value()\n" + "{\n" + " key=$1\n" + " file=$2\n" + " [ -f \"$file\" ] || return 1\n" + " sed -n \"s/^${key}=//p\" \"$file\" | tail -n 1\n" + "}\n" + "can_run_tui()\n" + "{\n" + " [ -x /usr/local/bin/fruix ] && command -v script >/dev/null 2>&1\n" + "}\n" + "select_tty_device()\n" + "{\n" + " if [ -n \"${FRUIX_INSTALLER_TTY:-}\" ] && [ -e \"$FRUIX_INSTALLER_TTY\" ]; then\n" + " printf '%s\\n' \"$FRUIX_INSTALLER_TTY\"\n" + " return 0\n" + " fi\n" + " boot_console=$(kenv console 2>/dev/null || true)\n" + " case \"$boot_console\" in\n" + " *vidconsole*)\n" + " if [ -e /dev/ttyv0 ]; then\n" + " printf '%s\\n' /dev/ttyv0\n" + " return 0\n" + " fi\n" + " ;;\n" + " esac\n" + " return 1\n" + "}\n" + "run_apply()\n" + "{\n" + " [ -x \"$apply_script\" ] || { log \"missing apply script: $apply_script\"; write_state apply-missing; exit 1; }\n" + " log \"running noninteractive apply\"\n" + " exec \"$apply_script\"\n" + "}\n" + "run_tui_self_test()\n" + "{\n" + " write_state tui-self-test\n" + " rm -f \"$tui_transcript\" \"$tui_metadata_file\"\n" + " if ! env TERM=\"$installer_term\" script -aq \"$tui_transcript\" /usr/local/bin/fruix system installer-tui --self-test >/dev/null 2>&1; then\n" + " clean_tui_metadata \"$tui_transcript\" \"$tui_metadata_file\" || true\n" + " log \"tui self-test command failed\"\n" + " write_state tui-self-test-failed\n" + " return 1\n" + " fi\n" + " clean_tui_metadata \"$tui_transcript\" \"$tui_metadata_file\" || true\n" + " newt_result=$(metadata_value newt_result \"$tui_metadata_file\" || true)\n" + " if [ \"$newt_result\" = self-test-ok ]; then\n" + " log \"tui self-test ok\"\n" + " write_state tui-self-test-ok\n" + " return 0\n" + " fi\n" + " log \"tui self-test unexpected result: ${newt_result:-missing}\"\n" + " write_state tui-self-test-failed\n" + " return 1\n" + "}\n" + "run_tui_session()\n" + "{\n" + " tty_device=$1\n" + " write_state launching-tui\n" + " rm -f \"$tui_transcript\" \"$tui_metadata_file\"\n" + " if env TERM=\"$installer_term\" script -aq \"$tui_transcript\" /usr/local/bin/fruix system installer-tui < \"$tty_device\" > \"$tty_device\" 2>&1; then\n" + " status=0\n" + " else\n" + " status=$?\n" + " fi\n" + " clean_tui_metadata \"$tui_transcript\" \"$tui_metadata_file\" || true\n" + " newt_result=$(metadata_value newt_result \"$tui_metadata_file\" || true)\n" + " case \"$newt_result\" in\n" + " proceed)\n" + " log \"tui proceed\"\n" + " write_state tui-proceed\n" + " return 0\n" + " ;;\n" + " abort)\n" + " log \"tui abort\"\n" + " write_state tui-abort\n" + " return 20\n" + " ;;\n" + " unavailable)\n" + " log \"tui unavailable\"\n" + " return 30\n" + " ;;\n" + " '')\n" + " log \"tui missing result status=$status\"\n" + " return 31\n" + " ;;\n" + " *)\n" + " log \"tui unexpected result: $newt_result status=$status\"\n" + " return 31\n" + " ;;\n" + " esac\n" + "}\n" + "log \"frontend=$frontend\"\n" + "case \"$frontend\" in\n" + " self-test)\n" + " if ! can_run_tui; then\n" + " log \"self-test requested but TUI runtime is unavailable\"\n" + " write_state tui-unavailable\n" + " exit 1\n" + " fi\n" + " run_tui_self_test\n" + " ;;\n" + " auto|tui)\n" + " if ! can_run_tui; then\n" + " if [ \"$frontend\" = auto ]; then\n" + " log \"tui runtime unavailable, falling back to noninteractive apply\"\n" + " run_apply\n" + " fi\n" + " write_state tui-unavailable\n" + " exit 1\n" + " fi\n" + " tty_device=$(select_tty_device || true)\n" + " if [ -z \"$tty_device\" ]; then\n" + " if [ \"$frontend\" = auto ]; then\n" + " log \"no TTY device found, falling back to noninteractive apply\"\n" + " run_apply\n" + " fi\n" + " write_state tui-no-tty\n" + " exit 1\n" + " fi\n" + " run_tui_session \"$tty_device\"\n" + " status=$?\n" + " case \"$status\" in\n" + " 0)\n" + " run_apply\n" + " ;;\n" + " 20)\n" + " exit 0\n" + " ;;\n" + " 30|31)\n" + " if [ \"$frontend\" = auto ]; then\n" + " log \"tui did not complete cleanly, falling back to noninteractive apply status=$status\"\n" + " run_apply\n" + " fi\n" + " write_state tui-failed\n" + " exit 1\n" + " ;;\n" + " *)\n" + " if [ \"$frontend\" = auto ]; then\n" + " log \"tui command failed, falling back to noninteractive apply status=$status\"\n" + " run_apply\n" + " fi\n" + " write_state tui-failed\n" + " exit \"$status\"\n" + " ;;\n" + " esac\n" + " ;;\n" + " noninteractive|apply)\n" + " run_apply\n" + " ;;\n" + " *)\n" + " log \"unknown frontend mode: $frontend\"\n" + " write_state invalid-frontend\n" + " exit 1\n" + " ;;\n" + "esac\n"))) + (define (render-installer-rc-script plan-directory) (string-append "#!/bin/sh\n" @@ -865,16 +1086,17 @@ "name=fruix_installer\n" "rcvar=fruix_installer_enable\n" ": ${fruix_installer_enable:=YES}\n" + ": ${fruix_installer_frontend:=auto}\n" + ": ${fruix_installer_tty:=}\n" "pidfile=/var/run/fruix-installer.pid\n" "command=/usr/sbin/daemon\n" - "command_args='-c -f -p /var/run/fruix-installer.pid -o /var/log/fruix-installer-bootstrap.out /usr/local/libexec/fruix-installer-run'\n" "start_cmd=fruix_installer_start\n" "stop_cmd=fruix_installer_stop\n" "status_cmd=fruix_installer_status\n\n" "fruix_installer_start()\n" "{\n" " mkdir -p '" plan-directory "' /var/run\n" - " $command $command_args\n" + " $command -c -f -p \"$pidfile\" -o /var/log/fruix-installer-bootstrap.out /usr/bin/env \"FRUIX_INSTALLER_FRONTEND=$fruix_installer_frontend\" \"FRUIX_INSTALLER_TTY=$fruix_installer_tty\" /usr/local/libexec/fruix-installer-run\n" "}\n\n" "fruix_installer_stop()\n" "{\n" @@ -1312,10 +1534,13 @@ (string-append (string-join (freebsd-storage-plan-mount-targets target-storage-plan) "\n") "\n")) (write-file (string-append plan-root "/state") "pending\n") + (write-file (string-append image-rootfs "/usr/local/libexec/fruix-installer-apply") + (render-installer-apply-script store-dir installer-plan-directory)) (write-file (string-append image-rootfs "/usr/local/libexec/fruix-installer-run") (render-installer-run-script store-dir installer-plan-directory)) (write-file (string-append image-rootfs "/usr/local/etc/rc.d/fruix-installer") (render-installer-rc-script installer-plan-directory)) + (chmod (string-append image-rootfs "/usr/local/libexec/fruix-installer-apply") #o555) (chmod (string-append image-rootfs "/usr/local/libexec/fruix-installer-run") #o555) (chmod (string-append image-rootfs "/usr/local/etc/rc.d/fruix-installer") #o555) (mkdir-p (string-append esp-stage "/EFI/BOOT")) @@ -1641,10 +1866,13 @@ (string-append (string-join (freebsd-storage-plan-mount-targets target-storage-plan) "\n") "\n")) (write-file (string-append plan-root "/state") "pending\n") + (write-file (string-append image-rootfs "/usr/local/libexec/fruix-installer-apply") + (render-installer-apply-script store-dir installer-plan-directory)) (write-file (string-append image-rootfs "/usr/local/libexec/fruix-installer-run") (render-installer-run-script store-dir installer-plan-directory)) (write-file (string-append image-rootfs "/usr/local/etc/rc.d/fruix-installer") (render-installer-rc-script installer-plan-directory)) + (chmod (string-append image-rootfs "/usr/local/libexec/fruix-installer-apply") #o555) (chmod (string-append image-rootfs "/usr/local/libexec/fruix-installer-run") #o555) (chmod (string-append image-rootfs "/usr/local/etc/rc.d/fruix-installer") #o555) (rewrite-installer-iso-fstab image-rootfs installer-closure-path) diff --git a/modules/fruix/system/freebsd/render.scm b/modules/fruix/system/freebsd/render.scm index c96c41f..18e73b6 100644 --- a/modules/fruix/system/freebsd/render.scm +++ b/modules/fruix/system/freebsd/render.scm @@ -493,8 +493,28 @@ (string-append (getenv "HOME") "/repos/guix"))) (specs `((,(string-append repo-root "/scripts/fruix.scm") . "share/fruix/node/scripts/fruix.scm") + (,(string-append repo-root "/modules/fruix/installer.scm") + . "share/fruix/node/modules/fruix/installer.scm") + (,(string-append repo-root "/modules/fruix/installer/final.scm") + . "share/fruix/node/modules/fruix/installer/final.scm") + (,(string-append repo-root "/modules/fruix/installer/flow.scm") + . "share/fruix/node/modules/fruix/installer/flow.scm") + (,(string-append repo-root "/modules/fruix/installer/newt.scm") + . "share/fruix/node/modules/fruix/installer/newt.scm") + (,(string-append repo-root "/modules/fruix/installer/state.scm") + . "share/fruix/node/modules/fruix/installer/state.scm") + (,(string-append repo-root "/modules/fruix/installer/steps.scm") + . "share/fruix/node/modules/fruix/installer/steps.scm") (,(string-append repo-root "/modules/fruix/packages/freebsd.scm") . "share/fruix/node/modules/fruix/packages/freebsd.scm") + (,(string-append repo-root "/modules/fruix/system/storage.scm") + . "share/fruix/node/modules/fruix/system/storage.scm") + (,(string-append repo-root "/modules/fruix/system/storage/model.scm") + . "share/fruix/node/modules/fruix/system/storage/model.scm") + (,(string-append repo-root "/modules/fruix/system/storage/render.scm") + . "share/fruix/node/modules/fruix/system/storage/render.scm") + (,(string-append repo-root "/modules/fruix/system/storage/validate.scm") + . "share/fruix/node/modules/fruix/system/storage/validate.scm") (,(string-append repo-root "/modules/fruix/system/freebsd.scm") . "share/fruix/node/modules/fruix/system/freebsd.scm") (,(string-append repo-root "/modules/fruix/system/freebsd/build.scm") @@ -509,6 +529,8 @@ . "share/fruix/node/modules/fruix/system/freebsd/render.scm") (,(string-append repo-root "/modules/fruix/system/freebsd/source.scm") . "share/fruix/node/modules/fruix/system/freebsd/source.scm") + (,(string-append repo-root "/modules/fruix/system/freebsd/storage.scm") + . "share/fruix/node/modules/fruix/system/freebsd/storage.scm") (,(string-append repo-root "/modules/fruix/system/freebsd/utils.scm") . "share/fruix/node/modules/fruix/system/freebsd/utils.scm") (,(string-append guix-root "/guix/build/utils.scm") @@ -518,7 +540,7 @@ (read-source-file-string (car entry)))) specs))) -(define (render-installed-system-fruix os guile-store guile-extra-store shepherd-store) +(define (render-installed-system-fruix os guile-store guile-extra-store shepherd-store guile-newt-store) (string-append "#!/bin/sh\n" "set -eu\n" @@ -547,6 +569,7 @@ "guile_store='" guile-store "'\n" "guile_extra_store='" guile-extra-store "'\n" "shepherd_store='" shepherd-store "'\n" + "guile_newt_store='" (or guile-newt-store "") "'\n" "layout_version=2\n" "host_name='" (operating-system-host-name os) "'\n" "ready_marker='" (operating-system-ready-marker os) "'\n" @@ -558,6 +581,7 @@ " fruix system build [DECLARATION [--system NAME] ...]\n" " fruix system build-base [--jobs COUNT] [--store DIR]\n" " fruix system deploy TARGET DECLARATION [--system NAME] ...\n" + " fruix system installer-tui [DECLARATION [--system NAME] ...]\n" " fruix system reconfigure [DECLARATION [--system NAME] ...]\n" " fruix system switch /frx/store/...-fruix-system-...\n" " fruix system rollback\n" @@ -621,12 +645,23 @@ " [ -d \"$node_module_root\" ] || die \"missing bundled Fruix modules: $node_module_root\"\n" " [ -d \"$node_guix_root\" ] || die \"missing bundled Guix modules: $node_guix_root\"\n" " guile_load_path=\"$node_module_root:$node_guix_root:$shepherd_store/share/guile/site/3.0:$guile_extra_store/share/guile/site/3.0\"\n" + " if [ -n \"$guile_newt_store\" ] && [ -d \"$guile_newt_store/share/guile/site/3.0\" ]; then\n" + " guile_load_path=\"$guile_load_path:$guile_newt_store/share/guile/site/3.0\"\n" + " fi\n" " guile_system_path=\"$guile_store/share/guile/3.0:$guile_store/share/guile/site/3.0:$guile_store/share/guile/site:$guile_store/share/guile\"\n" " guile_system_compiled_path=\"$guile_store/lib/guile/3.0/ccache:$guile_store/lib/guile/3.0/site-ccache\"\n" " guile_load_compiled_path=\"$shepherd_store/lib/guile/3.0/site-ccache:$guile_extra_store/lib/guile/3.0/site-ccache\"\n" " guile_system_extensions_path=\"$guile_store/lib/guile/3.0/extensions\"\n" " guile_extensions_path=\"$guile_extra_store/lib/guile/3.0/extensions\"\n" + " if [ -n \"$guile_newt_store\" ] && [ -d \"$guile_newt_store/lib/guile/3.0/extensions\" ]; then\n" + " guile_extensions_path=\"$guile_extensions_path:$guile_newt_store/lib/guile/3.0/extensions\"\n" + " fi\n" " ld_library_path=\"$guile_extra_store/lib:$guile_store/lib:/usr/local/lib\"\n" + " ltdl_library_path=\"$ld_library_path\"\n" + " if [ -n \"$guile_newt_store\" ] && [ -d \"$guile_newt_store/lib\" ]; then\n" + " ld_library_path=\"$guile_newt_store/lib:$ld_library_path\"\n" + " ltdl_library_path=\"$guile_newt_store/lib:$ltdl_library_path\"\n" + " fi\n" " env \\\n" " GUILE_AUTO_COMPILE=0 \\\n" " GUILE_SYSTEM_PATH=\"$guile_system_path\" \\\n" @@ -636,11 +671,14 @@ " GUILE_SYSTEM_EXTENSIONS_PATH=\"$guile_system_extensions_path\" \\\n" " GUILE_EXTENSIONS_PATH=\"$guile_extensions_path\" \\\n" " LD_LIBRARY_PATH=\"$ld_library_path\" \\\n" + " LTDL_LIBRARY_PATH=\"$ltdl_library_path\" \\\n" " GUILE_PREFIX=\"$guile_store\" \\\n" " GUILE_EXTRA_PREFIX=\"$guile_extra_store\" \\\n" + " GUILE_NEWT_PREFIX=\"$guile_newt_store\" \\\n" " SHEPHERD_PREFIX=\"$shepherd_store\" \\\n" " FRUIX_GUILE_STORE=\"$guile_store\" \\\n" " FRUIX_GUILE_EXTRA_STORE=\"$guile_extra_store\" \\\n" + " FRUIX_GUILE_NEWT_STORE=\"$guile_newt_store\" \\\n" " FRUIX_SHEPHERD_STORE=\"$shepherd_store\" \\\n" " GUIX_SOURCE_DIR=\"$node_guix_root\" \\\n" " FRUIX_PROJECT_ROOT=\"$node_root\" \\\n" @@ -740,6 +778,23 @@ " printf 'build_base=ok\\n'\n" " cleanup_build_base\n" "}\n\n" + "installer_tui()\n" + "{\n" + " if [ $# -eq 0 ]; then\n" + " ensure_default_declaration\n" + " run_node_cli system installer-tui \"$declaration_file\" --system \"$current_system_name\" --store \"$default_store_dir\"\n" + " else\n" + " case \"$1\" in\n" + " --*)\n" + " ensure_default_declaration\n" + " run_node_cli system installer-tui \"$declaration_file\" --system \"$current_system_name\" --store \"$default_store_dir\" \"$@\"\n" + " ;;\n" + " *)\n" + " run_node_cli system installer-tui \"$@\"\n" + " ;;\n" + " esac\n" + " fi\n" + "}\n\n" "reconfigure_system()\n" "{\n" " build_output=$(mktemp /tmp/fruix-system-reconfigure.XXXXXX)\n" @@ -966,6 +1021,10 @@ " shift 2\n" " deploy_system \"$@\"\n" " ;;\n" + " installer-tui)\n" + " shift 2\n" + " installer_tui \"$@\"\n" + " ;;\n" " reconfigure)\n" " shift 2\n" " reconfigure_system \"$@\"\n" @@ -1285,7 +1344,7 @@ "cat \"$metadata_file\"\n"))) -(define* (operating-system-generated-files os #:key guile-store guile-extra-store shepherd-store) +(define* (operating-system-generated-files os #:key guile-store guile-extra-store shepherd-store guile-newt-store) (append `(("boot/loader.conf" . ,(render-loader-conf os)) ("etc/rc.conf" . ,(render-rc.conf os)) @@ -1304,7 +1363,7 @@ #:shepherd-store shepherd-store)) ("shepherd/init.scm" . ,(render-shepherd-config os)) ("usr/local/bin/fruix" - . ,(render-installed-system-fruix os guile-store guile-extra-store shepherd-store))) + . ,(render-installed-system-fruix os guile-store guile-extra-store shepherd-store guile-newt-store))) (bundled-fruix-node-files) (if (null? (operating-system-development-packages os)) '() diff --git a/scripts/fruix.scm b/scripts/fruix.scm index 54b2913..8a6d017 100644 --- a/scripts/fruix.scm +++ b/scripts/fruix.scm @@ -39,6 +39,7 @@ System options:\n\ --target PATH Install target for 'install' (raw image file or /dev/... device).\n\ --install-target-device DEVICE\n\ Target block device used by the booted 'installer' environment.\n\ + --self-test Use the Newt self-test path for 'installer-tui'.\n\ --rootfs DIR Rootfs target for 'rootfs'.\n\ --host HOST Remote host for 'deploy' (or use TARGET as first positional argument).\n\ --user USER Remote SSH user for 'deploy' (default: root).\n\ @@ -157,7 +158,8 @@ Common options:\n\ (deploy-user "root") (deploy-port "22") (identity-file #f) - (reboot? #f)) + (reboot? #f) + (self-test? #f)) (match args (() (let ((positional (reverse positional))) @@ -175,65 +177,68 @@ Common options:\n\ (deploy-user . ,deploy-user) (deploy-port . ,deploy-port) (identity-file . ,identity-file) - (reboot? . ,reboot?)))) + (reboot? . ,reboot?) + (self-test? . ,self-test?)))) (("--help") (usage 0)) (((? (lambda (arg) (string-prefix? "--system=" arg)) arg) . tail) - (loop tail positional (option-value arg "--system=") store-dir disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot?)) + (loop tail positional (option-value arg "--system=") store-dir disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot? self-test?)) (("--system" value . tail) - (loop tail positional value store-dir disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot?)) + (loop tail positional value store-dir disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot? self-test?)) (((? (lambda (arg) (string-prefix? "--store=" arg)) arg) . tail) - (loop tail positional system-name (option-value arg "--store=") disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot?)) + (loop tail positional system-name (option-value arg "--store=") disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot? self-test?)) (("--store" value . tail) - (loop tail positional system-name value disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot?)) + (loop tail positional system-name value disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot? self-test?)) (((? (lambda (arg) (string-prefix? "--disk-capacity=" arg)) arg) . tail) - (loop tail positional system-name store-dir (option-value arg "--disk-capacity=") root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot?)) + (loop tail positional system-name store-dir (option-value arg "--disk-capacity=") root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot? self-test?)) (("--disk-capacity" value . tail) - (loop tail positional system-name store-dir value root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot?)) + (loop tail positional system-name store-dir value root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot? self-test?)) (((? (lambda (arg) (string-prefix? "--root-size=" arg)) arg) . tail) - (loop tail positional system-name store-dir disk-capacity (option-value arg "--root-size=") target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot?)) + (loop tail positional system-name store-dir disk-capacity (option-value arg "--root-size=") target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot? self-test?)) (("--root-size" value . tail) - (loop tail positional system-name store-dir disk-capacity value target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot?)) + (loop tail positional system-name store-dir disk-capacity value target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot? self-test?)) (((? (lambda (arg) (string-prefix? "--target=" arg)) arg) . tail) - (loop tail positional system-name store-dir disk-capacity root-size (option-value arg "--target=") install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot?)) + (loop tail positional system-name store-dir disk-capacity root-size (option-value arg "--target=") install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot? self-test?)) (("--target" value . tail) - (loop tail positional system-name store-dir disk-capacity root-size value install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot?)) + (loop tail positional system-name store-dir disk-capacity root-size value install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot? self-test?)) (((? (lambda (arg) (string-prefix? "--install-target-device=" arg)) arg) . tail) (loop tail positional system-name store-dir disk-capacity root-size target - (option-value arg "--install-target-device=") rootfs deploy-host deploy-user deploy-port identity-file reboot?)) + (option-value arg "--install-target-device=") rootfs deploy-host deploy-user deploy-port identity-file reboot? self-test?)) (("--install-target-device" value . tail) - (loop tail positional system-name store-dir disk-capacity root-size target value rootfs deploy-host deploy-user deploy-port identity-file reboot?)) + (loop tail positional system-name store-dir disk-capacity root-size target value rootfs deploy-host deploy-user deploy-port identity-file reboot? self-test?)) (((? (lambda (arg) (string-prefix? "--rootfs=" arg)) arg) . tail) (loop tail positional system-name store-dir disk-capacity root-size target install-target-device - (option-value arg "--rootfs=") deploy-host deploy-user deploy-port identity-file reboot?)) + (option-value arg "--rootfs=") deploy-host deploy-user deploy-port identity-file reboot? self-test?)) (("--rootfs" value . tail) - (loop tail positional system-name store-dir disk-capacity root-size target install-target-device value deploy-host deploy-user deploy-port identity-file reboot?)) + (loop tail positional system-name store-dir disk-capacity root-size target install-target-device value deploy-host deploy-user deploy-port identity-file reboot? self-test?)) (((? (lambda (arg) (string-prefix? "--host=" arg)) arg) . tail) (loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs - (option-value arg "--host=") deploy-user deploy-port identity-file reboot?)) + (option-value arg "--host=") deploy-user deploy-port identity-file reboot? self-test?)) (("--host" value . tail) - (loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs value deploy-user deploy-port identity-file reboot?)) + (loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs value deploy-user deploy-port identity-file reboot? self-test?)) (((? (lambda (arg) (string-prefix? "--user=" arg)) arg) . tail) (loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs - deploy-host (option-value arg "--user=") deploy-port identity-file reboot?)) + deploy-host (option-value arg "--user=") deploy-port identity-file reboot? self-test?)) (("--user" value . tail) - (loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs deploy-host value deploy-port identity-file reboot?)) + (loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs deploy-host value deploy-port identity-file reboot? self-test?)) (((? (lambda (arg) (string-prefix? "--port=" arg)) arg) . tail) (loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs - deploy-host deploy-user (option-value arg "--port=") identity-file reboot?)) + deploy-host deploy-user (option-value arg "--port=") identity-file reboot? self-test?)) (("--port" value . tail) - (loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs deploy-host deploy-user value identity-file reboot?)) + (loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs deploy-host deploy-user value identity-file reboot? self-test?)) (((? (lambda (arg) (string-prefix? "--identity=" arg)) arg) . tail) (loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs - deploy-host deploy-user deploy-port (option-value arg "--identity=") reboot?)) + deploy-host deploy-user deploy-port (option-value arg "--identity=") reboot? self-test?)) (("--identity" value . tail) - (loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port value reboot?)) + (loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port value reboot? self-test?)) (("--reboot" . tail) - (loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file #t)) + (loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file #t self-test?)) + (("--self-test" . tail) + (loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot? #t)) (((? (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 target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot?))))) + (loop tail (cons arg positional) system-name store-dir disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot? self-test?))))) (define (parse-source-arguments action rest) (let loop ((args rest) @@ -622,26 +627,35 @@ Common options:\n\ (installer_store_item_count . ,(length installer-store-items)))))) (define (emit-installer-tui-metadata os-file resolved-symbol store-dir state result) - (emit-metadata - `((action . "installer-tui") - (os_file . ,os-file) - (system_variable . ,resolved-symbol) - (store_dir . ,store-dir) - (newt_available . ,(assoc-ref result 'available?)) - (newt_result . ,(assoc-ref result 'result)) - (missing_bindings . ,(assoc-ref result 'missing-bindings)) - (step_count . ,(assoc-ref result 'step-count)) - (step_ids . ,(assoc-ref result 'step-ids)) - (selected_step . ,(installer-state-selected-step state)) - (host_name . ,(installer-state-host-name state)) - (target_device . ,(installer-state-target-device state)) - (root_size . ,(installer-state-root-size state)) - (disk_capacity . ,(installer-state-disk-capacity state)) - (network_mode . ,(installer-state-network-mode state)) - (storage_layout . ,(and (installer-state-storage-layout state) - (storage-layout-spec (installer-state-storage-layout state)))) - (effective_storage_layout . ,(and (installer-state-effective-storage-layout state) - (storage-layout-spec (installer-state-effective-storage-layout state))))))) + (let* ((state-spec (or (assoc-ref result 'state) + (installer-state-spec state))) + (state-value (lambda (key fallback) + (let ((entry (assoc key state-spec))) + (if entry (cdr entry) fallback))))) + (emit-metadata + `((action . "installer-tui") + (os_file . ,os-file) + (system_variable . ,resolved-symbol) + (store_dir . ,store-dir) + (newt_mode . ,(assoc-ref result 'mode)) + (newt_available . ,(assoc-ref result 'available?)) + (newt_result . ,(assoc-ref result 'result)) + (newt_error . ,(or (assoc-ref result 'error) #f)) + (missing_bindings . ,(assoc-ref result 'missing-bindings)) + (step_count . ,(assoc-ref result 'step-count)) + (step_ids . ,(assoc-ref result 'step-ids)) + (selected_step . ,(state-value 'selected-step (installer-state-selected-step state))) + (host_name . ,(state-value 'host-name (installer-state-host-name state))) + (target_device . ,(state-value 'target-device (installer-state-target-device state))) + (root_size . ,(state-value 'root-size (installer-state-root-size state))) + (disk_capacity . ,(state-value 'disk-capacity (installer-state-disk-capacity state))) + (network_mode . ,(state-value 'network-mode (installer-state-network-mode state))) + (storage_layout . ,(state-value 'storage-layout + (and (installer-state-storage-layout state) + (storage-layout-spec (installer-state-storage-layout state))))) + (effective_storage_layout . ,(state-value 'effective-storage-layout + (and (installer-state-effective-storage-layout state) + (storage-layout-spec (installer-state-effective-storage-layout state))))))))) (define (emit-native-build-promotion-metadata store-dir result-root result) (emit-metadata @@ -862,6 +876,7 @@ Common options:\n\ (deploy-port (assoc-ref parsed 'deploy-port)) (identity-file (assoc-ref parsed 'identity-file)) (reboot? (assoc-ref parsed 'reboot?)) + (self-test? (assoc-ref parsed 'self-test?)) (system-name (assoc-ref parsed 'system-name)) (requested-symbol (and system-name (string->symbol system-name)))) (unless (member action '("build" "deploy" "image" "installer" "installer-iso" "installer-tui" "install" "rootfs")) @@ -899,7 +914,8 @@ Common options:\n\ (shepherd-prefix (or (getenv "SHEPHERD_PREFIX") "/tmp/shepherd-freebsd-validate-install")) (guile-store-path (getenv "FRUIX_GUILE_STORE")) (guile-extra-store-path (getenv "FRUIX_GUILE_EXTRA_STORE")) - (shepherd-store-path (getenv "FRUIX_SHEPHERD_STORE"))) + (shepherd-store-path (getenv "FRUIX_SHEPHERD_STORE")) + (guile-newt-store-path (getenv "FRUIX_GUILE_NEWT_STORE"))) (unless deploy-source (error "deploy action requires a declaration file or system closure path")) (if (system-closure-path? deploy-source) @@ -925,6 +941,7 @@ Common options:\n\ #:guile-store-path guile-store-path #:guile-extra-store-path guile-extra-store-path #:shepherd-store-path shepherd-store-path + #:guile-newt-store-path guile-newt-store-path #:declaration-source declaration-source #:declaration-origin deploy-source #:declaration-system-symbol resolved-symbol))) @@ -947,6 +964,7 @@ Common options:\n\ (guile-store-path (getenv "FRUIX_GUILE_STORE")) (guile-extra-store-path (getenv "FRUIX_GUILE_EXTRA_STORE")) (shepherd-store-path (getenv "FRUIX_SHEPHERD_STORE")) + (guile-newt-store-path (getenv "FRUIX_GUILE_NEWT_STORE")) (declaration-source (read-file-string os-file))) (cond ((string=? action "build") @@ -960,6 +978,7 @@ Common options:\n\ #:guile-store-path guile-store-path #:guile-extra-store-path guile-extra-store-path #:shepherd-store-path shepherd-store-path + #:guile-newt-store-path guile-newt-store-path #:declaration-source declaration-source #:declaration-origin os-file #:declaration-system-symbol resolved-symbol))) @@ -1032,7 +1051,9 @@ Common options:\n\ #:target-device seed-target-device #:root-size root-size #:disk-capacity disk-capacity)) - (result (run-newt-installer state))) + (result (if self-test? + (run-newt-self-test) + (run-newt-installer state)))) (emit-installer-tui-metadata os-file resolved-symbol store-dir state result))) ((string=? action "install") diff --git a/tests/installer-basic.scm b/tests/installer-basic.scm new file mode 100644 index 0000000..1db427d --- /dev/null +++ b/tests/installer-basic.scm @@ -0,0 +1,83 @@ +(use-modules (srfi srfi-64) + (srfi srfi-13) + (fruix installer) + (fruix system freebsd)) + +(define (make-test-state) + (installer-state + #:operating-system #f + #:storage-layout (default-freebsd-efi-ufs-storage-layout #:device #f) + #:target-device #f + #:host-name #f + #:root-size #f + #:disk-capacity #f + #:network-mode default-installer-network-mode + #:selected-step 'welcome + #:metadata '())) + +(define (response-state response) + (assoc-ref response 'state)) + +(define (response-result response) + (assoc-ref response 'result)) + +(test-begin "installer-basic") + +(let ((candidates (installer-target-device-candidates + (installer-state #:storage-layout (default-freebsd-efi-ufs-storage-layout #:device #f) + #:target-device "/dev/ada0" + #:host-name "seed" + #:selected-step 'target-disk) + #:kern-disks "cd0 ada1 ada0 md0 pass0 nvd0"))) + (test-equal "target-device candidate filtering" + '("/dev/ada0" "/dev/ada1" "/dev/nvd0") + candidates)) + +(let* ((response (run-installer-command-script + (make-test-state) + '((action next) + (set target-device "/dev/ada0") + (action next) + (action next) + (set host-name "apollo") + (action next) + (set network-mode dhcp) + (action next) + (action proceed)) + #:target-devices '("/dev/ada0" "/dev/ada1"))) + (state (response-state response))) + (test-equal "happy-path script result" 'proceed (response-result response)) + (test-equal "happy-path final step" 'install (installer-state-selected-step state)) + (test-equal "happy-path target device" "/dev/ada0" (installer-state-target-device state)) + (test-equal "happy-path host name" "apollo" (installer-state-host-name state)) + (test-equal "happy-path network mode" 'dhcp (installer-state-network-mode state)) + (test-assert "happy-path ready for install" + (installer-state-ready-for-install? state)) + (test-assert "happy-path review text mentions host" + (string-contains (installer-final-summary-text state) "host-name: apollo"))) + +(let* ((response (run-installer-command-script + (make-test-state) + '((action next) + (action next)) + #:target-devices '("/dev/ada0"))) + (state (response-state response))) + (test-equal "missing target device yields error" 'error (response-result response)) + (test-equal "missing target device stays on target step" 'target-disk (installer-state-selected-step state))) + +(let* ((response (run-installer-command-script + (make-test-state) + '((action next) + (set target-device "/dev/ada0") + (action next) + (action back)) + #:target-devices '("/dev/ada0"))) + (state (response-state response))) + (test-equal "back navigation returns to target-disk" 'target-disk (installer-state-selected-step state))) + +(let* ((response (installer-command-apply (make-test-state) + '(action proceed) + #:target-devices '("/dev/ada0")))) + (test-equal "proceed only valid from summary/install" 'error (response-result response))) + +(test-end "installer-basic") diff --git a/tests/run-installer-basic.sh b/tests/run-installer-basic.sh new file mode 100755 index 0000000..be71863 --- /dev/null +++ b/tests/run-installer-basic.sh @@ -0,0 +1,15 @@ +#!/bin/sh +set -eu + +repo_root=$(CDPATH= cd -- "$(dirname "$0")/.." && pwd) +. "$HOME/.local/opt/fruix-builder/env.sh" + +guile_version=$($GUILE_BIN -c '(display (effective-version))') +guile_load_path="$repo_root/modules:$GUIX_SOURCE_DIR:$HOME/.local/opt/fruix-builder/shepherd/share/guile/site/$guile_version${GUILE_LOAD_PATH:+:$GUILE_LOAD_PATH}" +guile_load_compiled_path="$HOME/.local/opt/fruix-builder/shepherd/lib/guile/$guile_version/site-ccache${GUILE_LOAD_COMPILED_PATH:+:$GUILE_LOAD_COMPILED_PATH}" + +env \ + GUILE_AUTO_COMPILE=0 \ + GUILE_LOAD_PATH="$guile_load_path" \ + GUILE_LOAD_COMPILED_PATH="$guile_load_compiled_path" \ + "$GUILE_BIN" --no-auto-compile "$repo_root/tests/installer-basic.scm"