system: split FreeBSD system module

docs/PROG_SUMMARY.md

@@ -32,6 +32,7 @@ Completed milestones include:
 - **Source-driven boot validation**: Fruix can now also boot systems built from distinct declared FreeBSD source revisions while preserving those source identities in image/build metadata.
 - **Explicit source policy**: the repo now records how FreeBSD source objects are fetched, cached, identified, invalidated, and consumed by native base builds in `docs/freebsd-source-policy.md`.
 - **Minimal installation workflow**: Fruix now has a non-interactive `fruix system install` path that can partition, format, populate, and boot a target image or disk from a declarative system closure.
+- **Minimal installer environment**: Fruix can now also build and boot a dedicated installer image that carries a selected target closure, installs it onto a second disk from inside the guest, and leaves the installed target bootable.
 - **Base upgrade story**: Fruix can now keep distinct declared base versions side by side in `/frx/store` and roll forward / back between them through the normal system deployment flow.
 
 ## Major pain points now behind us
@@ -46,7 +47,7 @@ Completed milestones include:
 ## Major pain points still ahead
 
 - **True store-native runtime artifacts**: some historical build/install prefixes are still embedded in binaries and metadata. They are no longer required at runtime, but the local Guile/guile-extra/Shepherd build/install flow should still be moved to a genuinely store-native prefix from the start.
-- **Installer environment**: Fruix now has a host-driven non-interactive install path, but it still lacks a dedicated Fruix-managed installer environment that can boot into an install context and run that workflow from within the target environment.
+- **Installer media beyond disk images**: Fruix now has both a host-driven install path and a bootable installer environment, but it still lacks a UEFI installer ISO and a more polished operator-facing installation medium.
 - **Boot-path simplification**: Fruix now supports both the legacy `freebsd-init+rc.d-shepherd` path and the more Guix-like `shepherd-pid1` path. We still need to decide whether Shepherd PID 1 becomes the preferred/default architecture.
 - **Reduce transitional FreeBSD glue**: more of the current bootstrap/activation/runtime setup should become cleaner and less prototype-specific over time.
 - **Tooling and platform constraints**: local bhyve remains blocked by missing nested virtualization under Xen, and XO permissions still prevent creating/importing new VDIs; current validation must keep reusing the approved VM/VDI path.
@@ -54,4 +55,4 @@ Completed milestones include:
 
 ## Bottom line
 
-Fruix has crossed the most important threshold: it is no longer just a collection of isolated FreeBSD experiments. It can now build declarative FreeBSD system artifacts, boot them on the real target VM, reach the network, serve SSH, run Shepherd as PID 1, operate from `/frx` without depending on temporary runtime-prefix shims, build native FreeBSD base artifacts into `/frx/store`, roll forward / back between declared base versions, materialize declared FreeBSD source inputs into `/frx/store`, drive native base builds from those materialized source snapshots, boot systems from distinct source revisions, explain the source provenance/invalidation rules explicitly, and install a declarative system onto a target image through a repeatable Fruix workflow. The biggest remaining work is no longer “can this build/install at all?” but “how does this become a fuller installer/deployment/generation story?”
+Fruix has crossed the most important threshold: it is no longer just a collection of isolated FreeBSD experiments. It can now build declarative FreeBSD system artifacts, boot them on the real target VM, reach the network, serve SSH, run Shepherd as PID 1, operate from `/frx` without depending on temporary runtime-prefix shims, build native FreeBSD base artifacts into `/frx/store`, roll forward / back between declared base versions, materialize declared FreeBSD source inputs into `/frx/store`, drive native base builds from those materialized source snapshots, boot systems from distinct source revisions, explain the source provenance/invalidation rules explicitly, install a declarative system onto a target image through a repeatable Fruix workflow, and boot a dedicated Fruix-managed installer environment that performs that installation from inside the guest. The biggest remaining work is no longer “can this build/install at all?” but “how does this become a fuller installer/deployment/generation/installer-media story?”

docs/reports/phase18-installer-environment-freebsd.md

@@ -0,0 +1,191 @@
+# Phase 18.2: minimal Fruix-managed installer environment on FreeBSD
+
+Date: 2026-04-04
+
+## Goal
+
+Phase 18.2 builds on the Phase 18.1 host-driven install primitive.
+
+The goal here is not a polished live installer. The goal is a small Fruix-managed environment that can:
+
+- boot as its own Fruix system,
+- carry a selected target Fruix system closure and rootfs payload,
+- install that target system onto a second disk from inside the booted environment,
+- and leave the installed target bootable.
+
+## Implementation
+
+### New installer-environment API
+
+Added in `modules/fruix/system/freebsd.scm`:
+
+- `installer-operating-system`
+- `operating-system-installer-image-spec`
+- `materialize-installer-image`
+
+The installer environment is derived from the selected target operating system, but with installer-specific behavior:
+
+- host name defaults to:
+  - `<target-host-name>-installer`
+- init mode is kept on the currently most stable installer path:
+  - `freebsd-init+rc.d-shepherd`
+- the installer image root label is distinct:
+  - `fruix-installer-root`
+- `sshd` is enabled for operator/debug access
+- installer accounts needed for SSH/DHCP are ensured if absent:
+  - `sshd`
+  - `_dhcp`
+
+### Bootable installer image contents
+
+`materialize-installer-image` now produces a bootable image that contains:
+
+- the installer system closure and its runtime store closure
+- the selected target system closure
+- the selected target system's referenced store items
+- a prebuilt target rootfs tree staged under:
+  - `/var/lib/fruix/installer/target-rootfs`
+- installer plan/state files under:
+  - `/var/lib/fruix/installer`
+- installer helper scripts:
+  - `/usr/local/libexec/fruix-installer-run`
+  - `/usr/local/etc/rc.d/fruix-installer`
+
+The booted installer environment runs a background rc.d job that:
+
+- partitions the selected target disk
+- creates EFI + UFS filesystems
+- copies the staged target rootfs onto the target
+- copies only the target system's required store items into the target `/frx/store`
+- installs the target's `loader.efi`
+- writes `/var/lib/fruix/install.scm` on the target
+- records installer state in:
+  - `/var/lib/fruix/installer/state`
+- logs to:
+  - `/var/log/fruix-installer.log`
+
+### New CLI action
+
+Added in `scripts/fruix.scm`:
+
+- `fruix system installer`
+
+Added option:
+
+- `--install-target-device DEVICE`
+
+This action materializes a bootable installer image in `/frx/store` and emits metadata for:
+
+- installer image paths
+- installer closure path
+- target closure path
+- target install device
+- installer state/log paths
+- declared/materialized FreeBSD source metadata
+- target/native/runtime store metadata
+
+### FreeBSD virtio target-device detail
+
+A practical detail surfaced during validation:
+
+- the correct FreeBSD virtio block device node for the second QEMU disk is:
+  - `/dev/vtbd1`
+
+The earlier Linux-flavored guess:
+
+- `/dev/vtblk1`
+
+was wrong for the actual FreeBSD device node namespace in this environment.
+
+The installer defaults were updated accordingly.
+
+### Small image-builder correctness fix
+
+While doing this work I also fixed `materialize-bhyve-image` so its generated UFS filesystem label respects the requested:
+
+- `root-partition-label`
+
+instead of always hardcoding:
+
+- `fruix-root`
+
+This matters for the installer image because it needs a distinct root label while the target disk still uses the normal target label.
+
+## Validation
+
+Added validation artifacts:
+
+- `tests/system/phase18-installer-target-operating-system.scm.in`
+- `tests/system/run-phase18-installer-environment.sh`
+
+Passing validations:
+
+- `PASS phase18-installer-environment`
+- regression re-check:
+  - `PASS phase18-system-install`
+- regression re-check:
+  - `PASS phase17-source-revisions-qemu`
+
+Validated installer-environment result:
+
+```text
+installer_image_store_path=/frx/store/fb038dbf5dac2ad1bb767a264d3a268915f489b936dc5dd32425645102d3da48-fruix-installer-image-fruix-freebsd-installer
+installer_disk_image=/frx/store/fb038dbf5dac2ad1bb767a264d3a268915f489b936dc5dd32425645102d3da48-fruix-installer-image-fruix-freebsd-installer/disk.img
+installer_disk_capacity=16g
+installer_root_size=14g
+target_disk_capacity=12g
+install_target_device=/dev/vtbd1
+installer_closure_path=/frx/store/ea821f20b579684877fdc86a2a1e80485cf2b12d9d32f74f42e368d738c2ad4d-fruix-system-fruix-freebsd-installer
+target_closure_path=/frx/store/7ee225db532b6973e385f8507d2d61aec3cd3aeb0864f983c2ae4b6e149ef3b0-fruix-system-fruix-freebsd
+freebsd_source_kind=git
+freebsd_source_ref=stable/15
+freebsd_source_commit=332708a606f6bf0841c1d4a74c0d067f5640fe89
+materialized_source_store=/frx/store/7563df2714ae7fa9bd40b83c74512ffe2cb2ad91b297915591b55c76edbb2fcb-freebsd-source-stable15-installer-target-source
+installer_state=done
+installer_sshd_status=running
+target_esp_fstype=msdosfs
+target_root_fstype=ufs
+target_shepherd_status=running
+target_sshd_status=running
+installer_environment_boot=ok
+installer_environment_install=ok
+installed_target_boot=ok
+```
+
+The harness verified all of the following:
+
+1. `fruix system installer` produces a bootable installer image in `/frx/store`
+2. validation boots a workdir copy of that installer disk image so the store artifact itself is not mutated during the boot/install run
+3. the installer environment boots successfully under QEMU/UEFI/TCG
+4. the installer environment becomes reachable over SSH
+5. `/run/current-system` inside the installer environment points at the installer closure
+6. the installer rc.d job reaches:
+   - `state=done`
+7. the installer log records:
+   - `fruix-installer:done`
+8. the target raw disk is transformed into a valid GPT-installed Fruix target with:
+   - EFI filesystem: `msdosfs`
+   - root filesystem: `ufs`
+   - `EFI/BOOT/BOOTX64.EFI` present
+   - `/var/lib/fruix/install.scm` present
+9. the installed target then boots successfully as its own Fruix system under QEMU/UEFI/TCG
+10. after target boot:
+   - `/run/current-system` points at the target closure
+   - `/usr/local/etc/rc.d/fruix-shepherd onestatus` reports running
+   - `sshd` is running
+   - activation completed successfully
+
+## Result
+
+Phase 18.2 is complete.
+
+Fruix now has a real installer substrate on FreeBSD:
+
+- a bootable Fruix-managed installer image
+- a target closure bundled inside that installer environment
+- in-guest non-interactive installation onto a second disk
+- validated boot of the installed result
+
+The next step is Phase 18.3:
+
+- produce a bootable installer ISO for UEFI systems, rather than only a disk-image-style installer environment.

modules/fruix/system/freebsd/build.scm

@@ -0,0 +1,470 @@
+(define-module (fruix system freebsd build)
+  #:use-module (fruix packages freebsd)
+  #:use-module (fruix system freebsd model)
+  #:use-module (fruix system freebsd source)
+  #:use-module (fruix system freebsd utils)
+  #:use-module (guix build utils)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 hash-table)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-13)
+  #:export (host-freebsd-provenance
+            materialize-freebsd-package
+            materialize-prefix))
+
+(define (host-freebsd-provenance)
+  (let ((src-git? (file-exists? "/usr/src/.git"))
+        (newvers "/usr/src/sys/conf/newvers.sh"))
+    `((freebsd-release . ,freebsd-release)
+      (freebsd-version-kru . ,(or (safe-command-output "freebsd-version" "-kru") "unknown"))
+      (uname . ,(or (safe-command-output "uname" "-a") "unknown"))
+      (usr-src-path . "/usr/src")
+      (usr-src-git-revision . ,(or (and src-git?
+                                        (safe-command-output "git" "-C" "/usr/src" "rev-parse" "HEAD"))
+                                   "absent"))
+      (usr-src-git-branch . ,(or (and src-git?
+                                      (safe-command-output "git" "-C" "/usr/src" "rev-parse" "--abbrev-ref" "HEAD"))
+                                 "absent"))
+      (usr-src-newvers-sha256 . ,(if (file-exists? newvers)
+                                     (file-hash newvers)
+                                     "absent")))))
+
+
+(define native-freebsd-build-version "1")
+
+(define (freebsd-native-build-system? build-system)
+  (not (not (memq build-system '(freebsd-kernel-build-system freebsd-world-build-system)))))
+
+(define (build-plan-ref plan key default)
+  (match (assoc key plan)
+    ((_ . value) value)
+    (#f default)))
+
+(define (make-flag->pair flag)
+  (match (string-split flag #\=)
+    ((name value ...) (cons name (string-join value "=")))
+    ((name) (cons name "yes"))
+    (_ (error (format #f "invalid make flag: ~a" flag)))))
+
+(define (native-build-kernconf-path plan)
+  (or (build-plan-ref plan 'kernconf-path #f)
+      (string-append (build-plan-ref plan 'source-root "/usr/src")
+                     "/sys/"
+                     (build-plan-ref plan 'target-arch "amd64")
+                     "/conf/"
+                     (build-plan-ref plan 'kernconf "GENERIC"))))
+
+(define (native-build-common-manifest plan)
+  (let* ((source-root (build-plan-ref plan 'source-root "/usr/src"))
+         (target (build-plan-ref plan 'target "amd64"))
+         (target-arch (build-plan-ref plan 'target-arch "amd64"))
+         (kernconf (build-plan-ref plan 'kernconf "GENERIC"))
+         (make-flags (build-plan-ref plan 'make-flags '()))
+         (kernconf-path (native-build-kernconf-path plan)))
+    (unless (file-exists? source-root)
+      (error (format #f "native FreeBSD source root does not exist: ~a" source-root)))
+    (unless (file-exists? kernconf-path)
+      (error (format #f "native FreeBSD kernconf does not exist: ~a" kernconf-path)))
+    `((build-version . ,native-freebsd-build-version)
+      (source-root . ,source-root)
+      (source-tree-identity-mode . "mtree:type,link,size,mode,sha256digest")
+      (source-tree-sha256 . ,(or (build-plan-ref plan 'materialized-source-tree-sha256 #f)
+                                 (native-build-source-tree-sha256 source-root)))
+      (target . ,target)
+      (target-arch . ,target-arch)
+      (kernconf . ,kernconf)
+      (kernconf-path . ,kernconf-path)
+      (kernconf-sha256 . ,(file-hash kernconf-path))
+      (make-flags . ,make-flags))))
+
+(define (native-build-declared-base plan)
+  `((name . ,(build-plan-ref plan 'base-name "default"))
+    (version-label . ,(build-plan-ref plan 'base-version-label freebsd-release))
+    (release . ,(build-plan-ref plan 'base-release freebsd-release))
+    (branch . ,(build-plan-ref plan 'base-branch "unknown"))))
+
+(define (native-build-declared-source plan)
+  `((name . ,(build-plan-ref plan 'base-source-name "default"))
+    (kind . ,(build-plan-ref plan 'base-source-kind 'local-tree))
+    (url . ,(build-plan-ref plan 'base-source-url #f))
+    (path . ,(build-plan-ref plan 'base-source-path #f))
+    (ref . ,(build-plan-ref plan 'base-source-ref #f))
+    (commit . ,(build-plan-ref plan 'base-source-commit #f))
+    (sha256 . ,(build-plan-ref plan 'base-source-sha256 #f))))
+
+(define (native-build-materialized-source plan)
+  `((store-path . ,(build-plan-ref plan 'materialized-source-store #f))
+    (source-root . ,(build-plan-ref plan 'source-root "/usr/src"))
+    (info-file . ,(build-plan-ref plan 'materialized-source-info-file #f))
+    (tree-sha256 . ,(build-plan-ref plan 'materialized-source-tree-sha256 #f))
+    (cache-path . ,(build-plan-ref plan 'materialized-source-cache-path #f))
+    (effective-source . ((kind . ,(build-plan-ref plan 'effective-source-kind #f))
+                         (url . ,(build-plan-ref plan 'effective-source-url #f))
+                         (path . ,(build-plan-ref plan 'effective-source-path #f))
+                         (ref . ,(build-plan-ref plan 'effective-source-ref #f))
+                         (commit . ,(build-plan-ref plan 'effective-source-commit #f))
+                         (sha256 . ,(build-plan-ref plan 'effective-source-sha256 #f))))))
+
+(define (native-build-manifest-string package input-paths)
+  (let* ((plan (freebsd-package-install-plan package))
+         (common (native-build-common-manifest plan))
+         (declared-base (native-build-declared-base plan))
+         (declared-source (native-build-declared-source plan))
+         (materialized-source (native-build-materialized-source plan))
+         (keep-paths (build-plan-ref plan 'keep-paths '()))
+         (prune-paths (build-plan-ref plan 'prune-paths '())))
+    (string-append
+     "name=" (freebsd-package-name package) "\n"
+     "version=" (freebsd-package-version package) "\n"
+     "build-system=" (symbol->string (freebsd-package-build-system package)) "\n"
+     "inputs=" (string-join input-paths ",") "\n"
+     "declared-base=\n"
+     (object->string declared-base)
+     "\ndeclared-source=\n"
+     (object->string declared-source)
+     "\nmaterialized-source=\n"
+     (object->string materialized-source)
+     "\nnative-build-common=\n"
+     (object->string common)
+     "\nkeep-paths=\n"
+     (object->string keep-paths)
+     "\nprune-paths=\n"
+     (object->string prune-paths))))
+
+(define (copy-build-manifest-string package input-paths)
+  (string-append
+   "name=" (freebsd-package-name package) "\n"
+   "version=" (freebsd-package-version package) "\n"
+   "build-system=" (symbol->string (freebsd-package-build-system package)) "\n"
+   "inputs=" (string-join input-paths ",") "\n"
+   "install-plan-signature=\n"
+   (string-join (map install-plan-signature
+                     (freebsd-package-install-plan package))
+                "\n")))
+
+(define (package-manifest-string package input-paths)
+  (if (freebsd-native-build-system? (freebsd-package-build-system package))
+      (native-build-manifest-string package input-paths)
+      (copy-build-manifest-string package input-paths)))
+
+(define (current-build-jobs)
+  (or (getenv "FRUIX_FREEBSD_BUILD_JOBS")
+      (safe-command-output "sysctl" "-n" "hw.ncpu")
+      "1"))
+
+(define (native-build-root common)
+  (string-append "/var/tmp/fruix-freebsd-native-build-"
+                 (string-hash (object->string common))))
+
+(define (native-make-arguments common _build-root)
+  (append
+   (list "-C" (assoc-ref common 'source-root)
+         (string-append "TARGET=" (assoc-ref common 'target))
+         (string-append "TARGET_ARCH=" (assoc-ref common 'target-arch))
+         (string-append "KERNCONF=" (assoc-ref common 'kernconf)))
+   (assoc-ref common 'make-flags)))
+
+(define* (make-command-string common build-root target #:key (parallel? #f) (destdir #f))
+  (string-join
+   (append
+    (list "env" (string-append "MAKEOBJDIRPREFIX=" build-root "/obj") "make")
+    (if parallel?
+        (list (string-append "-j" (current-build-jobs)))
+        '())
+    (native-make-arguments common build-root)
+    (if destdir
+        (list (string-append "DESTDIR=" destdir))
+        '())
+    (list target))
+   " "))
+
+(define (run-command/log log-file command)
+  (mkdir-p (dirname log-file))
+  (let ((status (system* "sh" "-c" (string-append command " >" log-file " 2>&1"))))
+    (unless (zero? status)
+      (error (format #f "command failed; see ~a: ~a" log-file command)))))
+
+(define (ensure-native-build-root common build-root)
+  (mkdir-p build-root)
+  (mkdir-p (string-append build-root "/logs"))
+  (mkdir-p (string-append build-root "/stamps"))
+  (write-file (string-append build-root "/build-parameters.scm")
+              (object->string common)))
+
+(define (ensure-native-buildworld common build-root)
+  (let ((stamp (string-append build-root "/stamps/buildworld.done")))
+    (ensure-native-build-root common build-root)
+    (unless (file-exists? stamp)
+      (run-command/log (string-append build-root "/logs/buildworld.log")
+                       (make-command-string common build-root "buildworld" #:parallel? #t))
+      (write-file stamp "ok\n"))))
+
+(define (ensure-native-buildkernel common build-root)
+  (let ((stamp (string-append build-root "/stamps/buildkernel-" (assoc-ref common 'kernconf) ".done")))
+    (ensure-native-buildworld common build-root)
+    (unless (file-exists? stamp)
+      (run-command/log (string-append build-root "/logs/buildkernel-" (assoc-ref common 'kernconf) ".log")
+                       (make-command-string common build-root "buildkernel" #:parallel? #t))
+      (write-file stamp "ok\n"))))
+
+(define (prune-stage-paths stage-root paths)
+  (for-each (lambda (path)
+              (delete-path-if-exists (string-append stage-root "/" path)))
+            paths))
+
+(define (select-stage-paths stage-root paths)
+  (let ((selected-root (string-append stage-root ".selected")))
+    (delete-path-if-exists selected-root)
+    (mkdir-p selected-root)
+    (for-each (lambda (path)
+                (let ((source (string-append stage-root "/" path))
+                      (target (string-append selected-root "/" path)))
+                  (unless (or (file-exists? source)
+                              (false-if-exception (readlink source)))
+                    (error (format #f "native stage path is missing: ~a" source)))
+                  (copy-node source target)))
+              paths)
+    selected-root))
+(define (native-build-output-metadata package common build-root stage-root)
+  (let ((plan (freebsd-package-install-plan package)))
+    `((package . ,(freebsd-package-name package))
+      (version . ,(freebsd-package-version package))
+      (declared-base . ,(native-build-declared-base plan))
+      (declared-source . ,(native-build-declared-source plan))
+      (materialized-source . ,(native-build-materialized-source plan))
+      (build-system . ,(freebsd-package-build-system package))
+      (source-root . ,(assoc-ref common 'source-root))
+      (source-tree-sha256 . ,(assoc-ref common 'source-tree-sha256))
+      (target . ,(assoc-ref common 'target))
+      (target-arch . ,(assoc-ref common 'target-arch))
+      (kernconf . ,(assoc-ref common 'kernconf))
+      (kernconf-path . ,(assoc-ref common 'kernconf-path))
+      (kernconf-sha256 . ,(assoc-ref common 'kernconf-sha256))
+      (make-flags . ,(assoc-ref common 'make-flags))
+      (keep-paths . ,(build-plan-ref plan 'keep-paths '()))
+      (prune-paths . ,(build-plan-ref plan 'prune-paths '()))
+      (build-root . ,build-root)
+      (stage-root . ,stage-root)
+      (buildworld-log . ,(string-append build-root "/logs/buildworld.log"))
+      (buildkernel-log . ,(string-append build-root "/logs/buildkernel-" (assoc-ref common 'kernconf) ".log"))
+      (install-log . ,(string-append build-root "/logs/install-" (freebsd-package-name package) ".log")))))
+
+(define (materialize-native-freebsd-package package input-paths manifest output-path)
+  (let* ((plan (freebsd-package-install-plan package))
+         (common (native-build-common-manifest plan))
+         (build-root (native-build-root common))
+         (stage-root (string-append build-root "/stage-" (freebsd-package-name package) "-" (string-hash manifest)))
+         (install-log (string-append build-root "/logs/install-" (freebsd-package-name package) ".log"))
+         (final-stage-root
+          (case (freebsd-package-build-system package)
+            ((freebsd-world-build-system)
+             (ensure-native-buildworld common build-root)
+             (delete-path-if-exists stage-root)
+             (mkdir-p stage-root)
+             (run-command/log install-log
+                              (string-append (make-command-string common build-root "installworld" #:destdir stage-root)
+                                             " && "
+                                             (make-command-string common build-root "distribution" #:destdir stage-root)))
+             (let* ((keep-paths (build-plan-ref plan 'keep-paths '()))
+                    (selected-root (if (null? keep-paths)
+                                       stage-root
+                                       (select-stage-paths stage-root keep-paths))))
+               (prune-stage-paths selected-root (build-plan-ref plan 'prune-paths '()))
+               selected-root))
+            ((freebsd-kernel-build-system)
+             (ensure-native-buildkernel common build-root)
+             (delete-path-if-exists stage-root)
+             (mkdir-p stage-root)
+             (run-command/log install-log
+                              (make-command-string common build-root "installkernel" #:destdir stage-root))
+             stage-root)
+            (else
+             (error (format #f "unsupported native FreeBSD build system: ~a"
+                            (freebsd-package-build-system package)))))))
+    (mkdir-p output-path)
+    (stage-tree-into-output final-stage-root output-path)
+    (write-file (string-append output-path "/.references")
+                (string-join input-paths "\n"))
+    (write-file (string-append output-path "/.fruix-package") manifest)
+    (write-file (string-append output-path "/.freebsd-native-build-info.scm")
+                (object->string (native-build-output-metadata package common build-root final-stage-root)))))
+
+(define (package-with-install-plan package install-plan)
+  (freebsd-package
+   #:name (freebsd-package-name package)
+   #:version (freebsd-package-version package)
+   #:build-system (freebsd-package-build-system package)
+   #:inputs (freebsd-package-inputs package)
+   #:home-page (freebsd-package-home-page package)
+   #:synopsis (freebsd-package-synopsis package)
+   #:description (freebsd-package-description package)
+   #:license (freebsd-package-license package)
+   #:install-plan install-plan))
+
+(define (plan-freebsd-source plan)
+  (freebsd-source #:name (build-plan-ref plan 'base-source-name "default")
+                  #:kind (build-plan-ref plan 'base-source-kind 'local-tree)
+                  #:url (build-plan-ref plan 'base-source-url #f)
+                  #:path (build-plan-ref plan 'base-source-path #f)
+                  #:ref (build-plan-ref plan 'base-source-ref #f)
+                  #:commit (build-plan-ref plan 'base-source-commit #f)
+                  #:sha256 (build-plan-ref plan 'base-source-sha256 #f)))
+
+(define (source-cache-key source)
+  (string-hash (object->string (freebsd-source-spec source))))
+
+(define (materialize-freebsd-source/cached source store-dir source-cache)
+  (let* ((key (source-cache-key source))
+         (cached (hash-ref source-cache key #f)))
+    (or cached
+        (let ((result (materialize-freebsd-source source #:store-dir store-dir)))
+          (hash-set! source-cache key result)
+          result))))
+
+(define (plan-with-materialized-source plan source-result)
+  (let* ((effective (assoc-ref source-result 'effective-source))
+         (overrides
+          `((source-root . ,(assoc-ref source-result 'source-root))
+            (materialized-source-store . ,(assoc-ref source-result 'source-store-path))
+            (materialized-source-info-file . ,(assoc-ref source-result 'source-info-file))
+            (materialized-source-tree-sha256 . ,(assoc-ref source-result 'source-tree-sha256))
+            (materialized-source-cache-path . ,(assoc-ref source-result 'cache-path))
+            (effective-source-kind . ,(assoc-ref effective 'kind))
+            (effective-source-url . ,(assoc-ref effective 'url))
+            (effective-source-path . ,(assoc-ref effective 'path))
+            (effective-source-ref . ,(assoc-ref effective 'ref))
+            (effective-source-commit . ,(assoc-ref effective 'commit))
+            (effective-source-sha256 . ,(assoc-ref effective 'sha256)))))
+    (append overrides plan)))
+
+(define* (materialize-freebsd-package package store-dir cache #:optional source-cache)
+  (let* ((source-cache (or source-cache (make-hash-table)))
+         (input-paths (map (lambda (input)
+                             (materialize-freebsd-package input store-dir cache source-cache))
+                           (freebsd-package-inputs package)))
+         (prepared-package
+          (if (freebsd-native-build-package? package)
+              (let* ((source (plan-freebsd-source (freebsd-package-install-plan package)))
+                     (source-result (materialize-freebsd-source/cached source store-dir source-cache))
+                     (plan (plan-with-materialized-source (freebsd-package-install-plan package)
+                                                         source-result)))
+                (package-with-install-plan package plan))
+              package))
+         (effective-input-paths
+          (if (freebsd-native-build-package? package)
+              (cons (build-plan-ref (freebsd-package-install-plan prepared-package)
+                                    'materialized-source-store
+                                    #f)
+                    input-paths)
+              input-paths))
+         (effective-input-paths (filter identity effective-input-paths))
+         (manifest (package-manifest-string prepared-package effective-input-paths))
+         (cache-key (string-hash manifest))
+         (cached (hash-ref cache cache-key #f)))
+    (if cached
+        cached
+        (let* ((hash (string-hash manifest))
+               (output-path (string-append store-dir "/" hash "-"
+                                           (freebsd-package-name prepared-package)
+                                           "-"
+                                           (freebsd-package-version prepared-package))))
+          (unless (file-exists? output-path)
+            (case (freebsd-package-build-system prepared-package)
+              ((copy-build-system)
+               (mkdir-p output-path)
+               (for-each (lambda (entry)
+                           (materialize-plan-entry output-path entry))
+                         (freebsd-package-install-plan prepared-package))
+               (write-file (string-append output-path "/.references")
+                           (string-join effective-input-paths "\n"))
+               (write-file (string-append output-path "/.fruix-package") manifest))
+              ((freebsd-world-build-system freebsd-kernel-build-system)
+               (materialize-native-freebsd-package prepared-package effective-input-paths manifest output-path))
+              (else
+               (error (format #f "unsupported package build system: ~a"
+                              (freebsd-package-build-system prepared-package))))))
+          (hash-set! cache cache-key output-path)
+          output-path))))
+
+
+(define (sanitize-materialized-prefix name output-path)
+  (cond
+   ((string=? name "fruix-guile-extra")
+    (rewrite-text-file
+     (string-append output-path "/share/guile/site/3.0/fibers/config.scm")
+     '(("((getenv \"FIBERS_BUILD_DIR\")\n    => (lambda (builddir) (in-vicinity builddir \".libs\")))\n   (else \"/tmp/guile-gnutls-freebsd-validate-install/lib/guile/3.0/extensions\"))"
+        . "((getenv \"FIBERS_BUILD_DIR\")\n    => (lambda (builddir) (in-vicinity builddir \".libs\")))\n   ((getenv \"GUILE_EXTENSIONS_PATH\"))\n   (else \"/usr/local/lib/guile/3.0/extensions\"))")))
+    (rewrite-text-file
+     (string-append output-path "/share/guile/site/3.0/gnutls.scm")
+     '(("\"/tmp/guile-gnutls-freebsd-validate-install/lib/guile/3.0/extensions\""
+        . "(or (getenv \"GUILE_EXTENSIONS_PATH\") \"/usr/local/lib/guile/3.0/extensions\")")))
+    (delete-file-if-exists (string-append output-path "/lib/guile/3.0/site-ccache/fibers/config.go"))
+    (delete-file-if-exists (string-append output-path "/lib/guile/3.0/site-ccache/gnutls.go")))
+   ((string=? name "fruix-shepherd-runtime")
+    (rewrite-text-file
+     (string-append output-path "/share/guile/site/3.0/shepherd/config.scm")
+     '(("(define Prefix-dir \"/tmp/shepherd-freebsd-validate-install\")"
+        . "(define Prefix-dir \"/frx\")")
+       ("(define %localstatedir \"/tmp/shepherd-freebsd-validate-install/var\")"
+        . "(define %localstatedir \"/var\")")
+       ("(define %runstatedir \"/tmp/shepherd-freebsd-validate-install/var/run\")"
+        . "(define %runstatedir \"/var/run\")")
+       ("(define %sysconfdir \"/tmp/shepherd-freebsd-validate-install/etc\")"
+        . "(define %sysconfdir \"/etc\")")
+       ("(define %localedir \"/tmp/shepherd-freebsd-validate-install/share/locale\")"
+        . "(define %localedir \"/usr/share/locale\")")
+       ("(define %pkglibdir \"/tmp/shepherd-freebsd-validate-install/lib/shepherd\")"
+        . "(define %pkglibdir \"/usr/local/lib/shepherd\")")))
+    (delete-file-if-exists (string-append output-path "/lib/guile/3.0/site-ccache/shepherd/config.go"))))
+  #t)
+
+(define (prefix-manifest-string source-path extra-files)
+  (string-append
+   "prefix-materializer-version=" prefix-materializer-version "\n"
+   "prefix-source=" source-path "\n"
+   (path-signature source-path)
+   (if (null? extra-files)
+       ""
+       (string-append
+        "\nextra-files=\n"
+        (string-join
+         (map (lambda (entry)
+                (string-append (cdr entry) "\n" (path-signature (car entry))))
+              extra-files)
+         "\n")))))
+
+(define (copy-extra-node source destination)
+  (let ((kind (stat:type (lstat source))))
+    (mkdir-p (dirname destination))
+    (case kind
+      ((symlink)
+       (unless (or (file-exists? destination)
+                   (false-if-exception (readlink destination)))
+         (let ((target (readlink source)))
+           (symlink target destination)
+           (unless (string-prefix? "/" target)
+             (copy-extra-node (string-append (dirname source) "/" target)
+                              (string-append (dirname destination) "/" target))))))
+      (else
+       (unless (file-exists? destination)
+         (copy-node source destination))))))
+
+(define* (materialize-prefix source-path name version store-dir #:key (extra-files '()))
+  (let* ((manifest (prefix-manifest-string source-path extra-files))
+         (hash (string-hash manifest))
+         (output-path (string-append store-dir "/" hash "-" name "-" version)))
+    (unless (file-exists? output-path)
+      (mkdir-p output-path)
+      (for-each (lambda (entry)
+                  (copy-node (string-append source-path "/" entry)
+                             (string-append output-path "/" entry)))
+                (directory-entries source-path))
+      (for-each (lambda (entry)
+                  (copy-extra-node (car entry)
+                                   (string-append output-path "/" (cdr entry))))
+                extra-files)
+      (sanitize-materialized-prefix name output-path)
+      (write-file (string-append output-path "/.fruix-package") manifest))
+    output-path))
+

modules/fruix/system/freebsd/model.scm

@@ -0,0 +1,334 @@
+(define-module (fruix system freebsd model)
+  #:use-module (fruix packages freebsd)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-13)
+  #:export (user-group
+            user-group?
+            user-group-name
+            user-group-gid
+            user-group-system?
+            user-account
+            user-account?
+            user-account-name
+            user-account-uid
+            user-account-group
+            user-account-supplementary-groups
+            user-account-comment
+            user-account-home
+            user-account-shell
+            user-account-system?
+            file-system
+            file-system?
+            file-system-device
+            file-system-mount-point
+            file-system-type
+            file-system-options
+            file-system-needed-for-boot?
+            operating-system
+            operating-system?
+            operating-system-host-name
+            operating-system-freebsd-base
+            operating-system-kernel
+            operating-system-bootloader
+            operating-system-base-packages
+            operating-system-users
+            operating-system-groups
+            operating-system-file-systems
+            operating-system-services
+            operating-system-loader-entries
+            operating-system-rc-conf-entries
+            operating-system-init-mode
+            operating-system-ready-marker
+            operating-system-root-authorized-keys
+            default-minimal-operating-system
+            freebsd-source-spec
+            freebsd-base-spec
+            validate-freebsd-source
+            validate-operating-system
+            pid1-init-mode?
+            effective-loader-entries
+            rc-conf-entry-value
+            sshd-enabled?
+            operating-system-generated-file-names
+            operating-system-closure-spec))
+
+(define-record-type <user-group>
+  (make-user-group name gid system?)
+  user-group?
+  (name user-group-name)
+  (gid user-group-gid)
+  (system? user-group-system?))
+
+(define* (user-group #:key name gid (system? #t))
+  (make-user-group name gid system?))
+
+(define-record-type <user-account>
+  (make-user-account name uid group supplementary-groups comment home shell system?)
+  user-account?
+  (name user-account-name)
+  (uid user-account-uid)
+  (group user-account-group)
+  (supplementary-groups user-account-supplementary-groups)
+  (comment user-account-comment)
+  (home user-account-home)
+  (shell user-account-shell)
+  (system? user-account-system?))
+
+(define* (user-account #:key name uid group (supplementary-groups '())
+                       (comment "Fruix user") (home "/nonexistent")
+                       (shell "/usr/sbin/nologin") (system? #t))
+  (make-user-account name uid group supplementary-groups comment home shell system?))
+
+(define-record-type <file-system>
+  (make-file-system device mount-point type options needed-for-boot?)
+  file-system?
+  (device file-system-device)
+  (mount-point file-system-mount-point)
+  (type file-system-type)
+  (options file-system-options)
+  (needed-for-boot? file-system-needed-for-boot?))
+
+(define* (file-system #:key device mount-point type (options "rw")
+                      (needed-for-boot? #f))
+  (make-file-system device mount-point type options needed-for-boot?))
+
+(define-record-type <operating-system>
+  (make-operating-system host-name freebsd-base kernel bootloader base-packages users groups
+                         file-systems services loader-entries rc-conf-entries
+                         init-mode ready-marker root-authorized-keys)
+  operating-system?
+  (host-name operating-system-host-name)
+  (freebsd-base operating-system-freebsd-base)
+  (kernel operating-system-kernel)
+  (bootloader operating-system-bootloader)
+  (base-packages operating-system-base-packages)
+  (users operating-system-users)
+  (groups operating-system-groups)
+  (file-systems operating-system-file-systems)
+  (services operating-system-services)
+  (loader-entries operating-system-loader-entries)
+  (rc-conf-entries operating-system-rc-conf-entries)
+  (init-mode operating-system-init-mode)
+  (ready-marker operating-system-ready-marker)
+  (root-authorized-keys operating-system-root-authorized-keys))
+
+(define* (operating-system #:key
+                           (host-name "fruix-freebsd")
+                           (freebsd-base %default-freebsd-base)
+                           (kernel freebsd-kernel)
+                           (bootloader freebsd-bootloader)
+                           (base-packages %freebsd-system-packages)
+                           (users (list (user-account #:name "root"
+                                                      #:uid 0
+                                                      #:group "wheel"
+                                                      #:comment "Charlie &"
+                                                      #:home "/root"
+                                                      #:shell "/bin/sh"
+                                                      #:system? #t)
+                                        (user-account #:name "operator"
+                                                      #:uid 1000
+                                                      #:group "operator"
+                                                      #:supplementary-groups '("wheel")
+                                                      #:comment "Fruix Operator"
+                                                      #:home "/home/operator"
+                                                      #:shell "/bin/sh"
+                                                      #:system? #f)))
+                           (groups (list (user-group #:name "wheel" #:gid 0 #:system? #t)
+                                         (user-group #:name "operator" #:gid 1000 #:system? #f)))
+                           (file-systems (list (file-system #:device "/dev/ufs/fruix-root"
+                                                            #:mount-point "/"
+                                                            #:type "ufs"
+                                                            #:options "rw"
+                                                            #:needed-for-boot? #t)
+                                               (file-system #:device "devfs"
+                                                            #:mount-point "/dev"
+                                                            #:type "devfs"
+                                                            #:options "rw"
+                                                            #:needed-for-boot? #t)
+                                               (file-system #:device "tmpfs"
+                                                            #:mount-point "/tmp"
+                                                            #:type "tmpfs"
+                                                            #:options "rw,size=64m"
+                                                            #:needed-for-boot? #f)))
+                           (services '(shepherd ready-marker))
+                           (loader-entries '(("autoboot_delay" . "1")
+                                             ("console" . "comconsole")))
+                           (rc-conf-entries '(("clear_tmp_enable" . "YES")
+                                              ("sendmail_enable" . "NONE")
+                                              ("sshd_enable" . "NO")))
+                           (init-mode 'freebsd-init+rc.d-shepherd)
+                           (ready-marker "/var/lib/fruix/ready")
+                           (root-authorized-keys '()))
+  (make-operating-system host-name freebsd-base kernel bootloader base-packages users groups
+                         file-systems services loader-entries rc-conf-entries
+                         init-mode ready-marker root-authorized-keys))
+
+(define default-minimal-operating-system (operating-system))
+
+(define (package-names packages)
+  (map freebsd-package-name packages))
+
+(define (freebsd-source-spec source)
+  `((name . ,(freebsd-source-name source))
+    (kind . ,(freebsd-source-kind source))
+    (url . ,(freebsd-source-url source))
+    (path . ,(freebsd-source-path source))
+    (ref . ,(freebsd-source-ref source))
+    (commit . ,(freebsd-source-commit source))
+    (sha256 . ,(freebsd-source-sha256 source))))
+
+(define (freebsd-base-spec base)
+  `((name . ,(freebsd-base-name base))
+    (version-label . ,(freebsd-base-version-label base))
+    (release . ,(freebsd-base-release base))
+    (branch . ,(freebsd-base-branch base))
+    (source-root . ,(freebsd-base-source-root base))
+    (source . ,(freebsd-source-spec (freebsd-base-source base)))
+    (target . ,(freebsd-base-target base))
+    (target-arch . ,(freebsd-base-target-arch base))
+    (kernconf . ,(freebsd-base-kernconf base))
+    (make-flags . ,(freebsd-base-make-flags base))))
+
+
+(define (duplicate-elements values)
+  (let loop ((rest values) (seen '()) (duplicates '()))
+    (match rest
+      (() (reverse duplicates))
+      ((head . tail)
+       (if (member head seen)
+           (loop tail seen (if (member head duplicates) duplicates (cons head duplicates)))
+           (loop tail (cons head seen) duplicates))))))
+
+(define (non-empty-string? value)
+  (and (string? value)
+       (not (string-null? value))))
+
+(define (validate-freebsd-source source)
+  (unless (freebsd-source? source)
+    (error "freebsd base source must be a <freebsd-source> record"))
+  (let ((kind (freebsd-source-kind source)))
+    (unless (member kind '(local-tree git src-txz))
+      (error "unsupported freebsd source kind" kind))
+    (case kind
+      ((local-tree)
+       (unless (non-empty-string? (freebsd-source-path source))
+         (error "local-tree freebsd source must declare a path" source)))
+      ((git)
+       (unless (non-empty-string? (freebsd-source-url source))
+         (error "git freebsd source must declare a URL" source))
+       (unless (or (non-empty-string? (freebsd-source-ref source))
+                   (non-empty-string? (freebsd-source-commit source)))
+         (error "git freebsd source must declare a ref or commit" source)))
+      ((src-txz)
+       (unless (non-empty-string? (freebsd-source-url source))
+         (error "src-txz freebsd source must declare a URL" source))
+       (unless (non-empty-string? (freebsd-source-sha256 source))
+         (error "src-txz freebsd source must declare a sha256" source)))))
+  #t)
+
+(define (validate-operating-system os)
+  (let* ((host-name (operating-system-host-name os))
+         (base (operating-system-freebsd-base os))
+         (users (operating-system-users os))
+         (groups (operating-system-groups os))
+         (file-systems (operating-system-file-systems os))
+         (user-names (map user-account-name users))
+         (group-names (map user-group-name groups))
+         (mount-points (map file-system-mount-point file-systems))
+         (init-mode (operating-system-init-mode os)))
+    (when (string-null? host-name)
+      (error "operating-system host-name must not be empty"))
+    (unless (freebsd-base? base)
+      (error "operating-system freebsd-base must be a <freebsd-base> record"))
+    (validate-freebsd-source (freebsd-base-source base))
+    (let ((dups (duplicate-elements user-names)))
+      (unless (null? dups)
+        (error "duplicate user names in operating-system" dups)))
+    (let ((dups (duplicate-elements group-names)))
+      (unless (null? dups)
+        (error "duplicate group names in operating-system" dups)))
+    (unless (member "/" mount-points)
+      (error "operating-system must declare a root file-system"))
+    (unless (member "root" user-names)
+      (error "operating-system must declare a root user"))
+    (unless (member "wheel" group-names)
+      (error "operating-system must declare a wheel group"))
+    (unless (member init-mode '(freebsd-init+rc.d-shepherd shepherd-pid1))
+      (error "unsupported operating-system init-mode" init-mode))
+    #t))
+
+(define (pid1-init-mode? os)
+  (eq? (operating-system-init-mode os) 'shepherd-pid1))
+
+(define (effective-loader-entries os)
+  (append (if (pid1-init-mode? os)
+              '(("init_exec" . "/run/current-system/boot/fruix-pid1"))
+              '())
+          (operating-system-loader-entries os)))
+
+(define (rc-conf-entry-value os key)
+  (let ((entry (assoc key (operating-system-rc-conf-entries os))))
+    (and entry (cdr entry))))
+
+(define (sshd-enabled? os)
+  (let ((value (rc-conf-entry-value os "sshd_enable")))
+    (and value
+         (member (string-upcase value) '("YES" "TRUE" "1")))))
+
+
+(define (operating-system-generated-file-names os)
+  (append
+   '("boot/loader.conf"
+     "etc/rc.conf"
+     "etc/fstab"
+     "etc/hosts"
+     "etc/passwd"
+     "etc/master.passwd"
+     "etc/group"
+     "etc/login.conf"
+     "etc/shells"
+     "etc/motd"
+     "etc/ttys"
+     "metadata/freebsd-base.scm"
+     "metadata/host-base-provenance.scm"
+     "metadata/store-layout.scm"
+     "activate"
+     "shepherd/init.scm")
+   (if (pid1-init-mode? os)
+       '("boot/fruix-pid1")
+       '())
+   (if (sshd-enabled? os)
+       '("etc/ssh/sshd_config")
+       '())
+   (if (null? (operating-system-root-authorized-keys os))
+       '()
+       '("root/.ssh/authorized_keys"))))
+
+
+(define (operating-system-closure-spec os)
+  (validate-operating-system os)
+  `((host-name . ,(operating-system-host-name os))
+    (freebsd-base . ,(freebsd-base-spec (operating-system-freebsd-base os)))
+    (kernel-package . ,(freebsd-package-name (operating-system-kernel os)))
+    (bootloader-package . ,(freebsd-package-name (operating-system-bootloader os)))
+    (base-package-count . ,(length (operating-system-base-packages os)))
+    (base-packages . ,(package-names (operating-system-base-packages os)))
+    (user-count . ,(length (operating-system-users os)))
+    (users . ,(map user-account-name (operating-system-users os)))
+    (group-count . ,(length (operating-system-groups os)))
+    (groups . ,(map user-group-name (operating-system-groups os)))
+    (file-system-count . ,(length (operating-system-file-systems os)))
+    (file-systems . ,(map (lambda (fs)
+                            `((device . ,(file-system-device fs))
+                              (mount-point . ,(file-system-mount-point fs))
+                              (type . ,(file-system-type fs))
+                              (options . ,(file-system-options fs))
+                              (needed-for-boot? . ,(file-system-needed-for-boot? fs))))
+                          (operating-system-file-systems os)))
+    (services . ,(operating-system-services os))
+    (generated-files . ,(operating-system-generated-file-names os))
+    (init-mode . ,(operating-system-init-mode os))
+    (ready-marker . ,(operating-system-ready-marker os))))
+

modules/fruix/system/freebsd/render.scm

@@ -0,0 +1,499 @@
+(define-module (fruix system freebsd render)
+  #:use-module (fruix system freebsd model)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-13)
+  #:export (operating-system-generated-files
+            render-activation-rc-script
+            render-rc-script))
+
+(define (render-loader-conf os)
+  (string-append
+   (string-join (map (lambda (entry)
+                       (format #f "~a=\"~a\"" (car entry) (cdr entry)))
+                     (effective-loader-entries os))
+                "\n")
+   "\n"))
+
+(define (render-rc.conf os)
+  (let* ((entries (append `(("hostname" . ,(operating-system-host-name os))
+                            ("fruix_activate_enable" . "YES")
+                            ("fruix_shepherd_enable" . "YES"))
+                          (operating-system-rc-conf-entries os))))
+    (string-append
+     (string-join (map (lambda (entry)
+                         (format #f "~a=\"~a\"" (car entry) (cdr entry)))
+                       entries)
+                  "\n")
+     "\n")))
+
+(define (group-name->gid groups name)
+  (let ((group (find (lambda (item)
+                       (string=? (user-group-name item) name))
+                     groups)))
+    (and group (user-group-gid group))))
+
+(define (render-passwd os)
+  (let ((groups (operating-system-groups os)))
+    (string-append
+     (string-join
+      (map (lambda (account)
+             (format #f "~a:*:~a:~a:~a:~a:~a"
+                     (user-account-name account)
+                     (user-account-uid account)
+                     (or (group-name->gid groups (user-account-group account))
+                         (error "unknown primary group" (user-account-group account)))
+                     (user-account-comment account)
+                     (user-account-home account)
+                     (user-account-shell account)))
+           (operating-system-users os))
+      "\n")
+     "\n")))
+
+(define (render-master-passwd os)
+  (let ((groups (operating-system-groups os)))
+    (string-append
+     (string-join
+      (map (lambda (account)
+             (format #f "~a:*:~a:~a::0:0:~a:~a:~a"
+                     (user-account-name account)
+                     (user-account-uid account)
+                     (or (group-name->gid groups (user-account-group account))
+                         (error "unknown primary group" (user-account-group account)))
+                     (user-account-comment account)
+                     (user-account-home account)
+                     (user-account-shell account)))
+           (operating-system-users os))
+      "\n")
+     "\n")))
+
+(define (render-group os)
+  (let ((users (operating-system-users os)))
+    (string-append
+     (string-join
+      (map (lambda (group)
+             (let ((members (filter-map (lambda (account)
+                                          (and (member (user-group-name group)
+                                                       (user-account-supplementary-groups account))
+                                               (user-account-name account)))
+                                        users)))
+               (format #f "~a:*:~a:~a"
+                       (user-group-name group)
+                       (user-group-gid group)
+                       (string-join members ","))))
+           (operating-system-groups os))
+      "\n")
+     "\n")))
+
+(define (fstab-fsck-fields fs)
+  (if (string=? (file-system-type fs) "ufs")
+      (if (string=? (file-system-mount-point fs) "/")
+          '(1 1)
+          '(2 2))
+      '(0 0)))
+
+(define (render-fstab os)
+  (string-append
+   (string-join
+    (map (lambda (fs)
+           (let ((checks (fstab-fsck-fields fs)))
+             (format #f "~a\t~a\t~a\t~a\t~a\t~a"
+                     (file-system-device fs)
+                     (file-system-mount-point fs)
+                     (file-system-type fs)
+                     (file-system-options fs)
+                     (first checks)
+                     (second checks))))
+         (operating-system-file-systems os))
+    "\n")
+   "\n"))
+
+(define (render-hosts os)
+  (string-append
+   "127.0.0.1\tlocalhost " (operating-system-host-name os) "\n"
+   "::1\tlocalhost\n"))
+
+(define (render-shells os)
+  (let ((shells (delete-duplicates (map user-account-shell (operating-system-users os)))))
+    (string-append (string-join shells "\n") "\n")))
+
+(define (render-motd os)
+  (string-append "Welcome to Fruix on FreeBSD (" (operating-system-host-name os) ")\n"))
+
+(define (render-login-conf)
+  (string-append
+   "default:\\\n"
+   "\t:path=/sbin /bin /usr/sbin /usr/bin /usr/local/sbin /usr/local/bin:\\\n"
+   "\t:umask=022:\\\n"
+   "\t:charset=UTF-8:\\\n"
+   "\t:lang=C.UTF-8:\n"
+   "daemon:\\\n"
+   "\t:path=/sbin /bin /usr/sbin /usr/bin /usr/local/sbin /usr/local/bin:\\\n"
+   "\t:tc=default:\n"
+   "root:\\\n"
+   "\t:ignorenologin:\\\n"
+   "\t:tc=default:\n"))
+
+(define (render-ttys)
+  (string-append
+   "console\tnone\tunknown\toff secure\n"
+   "ttyu0\tnone\tvt100\toff secure\n"
+   "xc0\tnone\txterm\toff secure\n"))
+
+(define (render-root-authorized-keys os)
+  (if (null? (operating-system-root-authorized-keys os))
+      ""
+      (string-append
+       (string-join (operating-system-root-authorized-keys os) "\n")
+       "\n")))
+
+(define (render-sshd-config os)
+  (string-append
+   "Port 22\n"
+   "PermitRootLogin yes\n"
+   "PasswordAuthentication no\n"
+   "KbdInteractiveAuthentication no\n"
+   "ChallengeResponseAuthentication no\n"
+   "UsePAM no\n"
+   "PubkeyAuthentication yes\n"
+   "AuthorizedKeysFile .ssh/authorized_keys\n"
+   "PidFile /var/run/sshd.pid\n"
+   "UseDNS no\n"))
+
+(define* (render-activation-script os #:key guile-store guile-extra-store shepherd-store)
+  (let* ((users (operating-system-users os))
+         (groups (operating-system-groups os))
+         (home-setup
+          (string-join
+           (map (lambda (account)
+                  (let ((name (user-account-name account))
+                        (uid (user-account-uid account))
+                        (gid (or (group-name->gid groups (user-account-group account))
+                                 (error "unknown primary group" (user-account-group account))))
+                        (home (user-account-home account))
+                        (system? (user-account-system? account)))
+                    (string-append
+                     "mkdir -p " home "\n"
+                     (if (or (string=? name "root") system?)
+                         ""
+                         (format #f "if [ -x /usr/sbin/chown ]; then /usr/sbin/chown ~a:~a ~a 2>/dev/null || true; fi\n"
+                                 uid gid home)))))
+                users)
+           ""))
+         (refresh-db-input-files
+          (string-join
+           (map (lambda (entry)
+                  (match entry
+                    ((name mode)
+                     (string-append
+                      "if [ -f /run/current-system/etc/" name " ]; then rm -f /etc/" name "; cp /run/current-system/etc/" name " /etc/" name "; chmod " mode " /etc/" name "; fi\n"))))
+                '(("passwd" "0644")
+                  ("master.passwd" "0600")
+                  ("group" "0644")
+                  ("login.conf" "0644")))
+           ""))
+         (ssh-section
+          (string-append
+           "mkdir -p /var/empty /etc/ssh /root/.ssh\n"
+           "chmod 700 /root/.ssh\n"
+           (if (null? (operating-system-root-authorized-keys os))
+               ""
+               "if [ -f /run/current-system/root/.ssh/authorized_keys ]; then cp /run/current-system/root/.ssh/authorized_keys /root/.ssh/authorized_keys; chmod 600 /root/.ssh/authorized_keys; fi\n")
+           (if (sshd-enabled? os)
+               "if [ -x /usr/bin/ssh-keygen ]; then /usr/bin/ssh-keygen -A; fi\n"
+               ""))))
+    (string-append
+     "#!/bin/sh\n"
+     "set -eu\n"
+     "logfile=/var/log/fruix-activate.log\n"
+     "mkdir -p /var/cron /var/db /var/lib/fruix /var/log /var/run /root /home /tmp\n"
+     ": >> \"$logfile\"\n"
+     "trap 'status=$?; echo \"fruix-activate:exit status=$status\" >> \"$logfile\"' EXIT\n"
+     "echo \"fruix-activate:start\" >> \"$logfile\"\n"
+     "chmod 1777 /tmp\n"
+     refresh-db-input-files
+     "if [ -x /usr/bin/cap_mkdb ] && [ -f /etc/login.conf ]; then\n"
+     "  if /usr/bin/cap_mkdb /etc/login.conf; then echo \"fruix-activate:cap_mkdb=ok\" >> \"$logfile\"; else echo \"fruix-activate:cap_mkdb=failed\" >> \"$logfile\"; fi\n"
+     "fi\n"
+     "if [ -x /usr/sbin/pwd_mkdb ] && [ -f /etc/master.passwd ]; then\n"
+     "  if /usr/sbin/pwd_mkdb -p /etc/master.passwd; then echo \"fruix-activate:pwd_mkdb=ok\" >> \"$logfile\"; else echo \"fruix-activate:pwd_mkdb=failed\" >> \"$logfile\"; fi\n"
+     "fi\n"
+     home-setup
+     ssh-section
+     "echo \"fruix-activate:done\" >> \"$logfile\"\n")))
+
+(define (pid1-mount-commands os)
+  (string-join
+   (filter-map (lambda (fs)
+                 (and (not (string=? "/" (file-system-mount-point fs)))
+                      (string-append
+                       "mkdir -p '" (file-system-mount-point fs) "'\n"
+                       "/sbin/mount -t '" (file-system-type fs)
+                       "' -o '" (file-system-options fs)
+                       "' '" (file-system-device fs)
+                       "' '" (file-system-mount-point fs)
+                       "' >/dev/null 2>&1 || true\n")))
+               (operating-system-file-systems os))
+   ""))
+
+(define (render-pid1-script os shepherd-store guile-store guile-extra-store)
+  (let ((ld-library-path (string-append guile-extra-store "/lib:"
+                                        guile-store "/lib:/usr/local/lib"))
+        (guile-system-path
+         (string-append guile-store "/share/guile/3.0:"
+                        guile-store "/share/guile/site/3.0:"
+                        guile-store "/share/guile/site:"
+                        guile-store "/share/guile"))
+        (guile-load-path (string-append shepherd-store "/share/guile/site/3.0:"
+                                        guile-extra-store "/share/guile/site/3.0"))
+        (guile-system-compiled-path
+         (string-append guile-store "/lib/guile/3.0/ccache:"
+                        guile-store "/lib/guile/3.0/site-ccache"))
+        (guile-load-compiled-path
+         (string-append shepherd-store "/lib/guile/3.0/site-ccache:"
+                        guile-extra-store "/lib/guile/3.0/site-ccache"))
+        (guile-system-extensions-path (string-append guile-store "/lib/guile/3.0/extensions"))
+        (guile-extensions-path (string-append guile-extra-store "/lib/guile/3.0/extensions")))
+    (string-append
+     "#!/bin/sh\n"
+     "set -eu\n"
+     "PATH=/sbin:/bin:/usr/sbin:/usr/bin:/usr/local/sbin:/usr/local/bin\n"
+     "/sbin/mount -u -o rw / >/dev/null 2>&1 || true\n"
+     (pid1-mount-commands os)
+     "/bin/hostname '" (operating-system-host-name os) "' >/dev/null 2>&1 || true\n"
+     "/run/current-system/activate\n"
+     "export GUILE_AUTO_COMPILE=0\n"
+     "export LANG='C.UTF-8'\n"
+     "export LC_ALL='C.UTF-8'\n"
+     "export LD_LIBRARY_PATH='" ld-library-path "'\n"
+     "export GUILE_SYSTEM_PATH='" guile-system-path "'\n"
+     "export GUILE_LOAD_PATH='" guile-load-path "'\n"
+     "export GUILE_SYSTEM_COMPILED_PATH='" guile-system-compiled-path "'\n"
+     "export GUILE_LOAD_COMPILED_PATH='" guile-load-compiled-path "'\n"
+     "export GUILE_SYSTEM_EXTENSIONS_PATH='" guile-system-extensions-path "'\n"
+     "export GUILE_EXTENSIONS_PATH='" guile-extensions-path "'\n"
+     "exec " guile-store "/bin/guile --no-auto-compile " shepherd-store "/bin/shepherd -I -s /var/run/shepherd.sock -c /run/current-system/shepherd/init.scm --pid=/var/run/shepherd.pid -l /var/log/shepherd.log\n")))
+
+(define (render-shepherd-config os)
+  (let* ((ready-marker (operating-system-ready-marker os))
+         (pid1? (pid1-init-mode? os))
+         (start-sshd? (and pid1? (or (sshd-enabled? os)
+                                     (member 'sshd (operating-system-services os)))))
+         (ready-requirements (if start-sshd?
+                                 "'(fruix-logger sshd)"
+                                 "'(fruix-logger)"))
+         (pid1-helpers
+          (if pid1?
+              (string-append
+               "(define (run-command program . args)\n"
+               "  (let ((status (apply system* program args)))\n"
+               "    (unless (zero? status)\n"
+               "      (error \"command failed\" (cons program args) status))\n"
+               "    #t))\n\n"
+               "(define* (freebsd-rc-service provision script-name\n"
+               "                             #:key\n"
+               "                             (requirement '())\n"
+               "                             (documentation\n"
+               "                              \"Manage a FreeBSD rc.d service through 'service'.\"))\n"
+               "  (service provision\n"
+               "    #:documentation documentation\n"
+               "    #:requirement requirement\n"
+               "    #:start (lambda _\n"
+               "              (run-command \"/usr/sbin/service\" script-name \"onestart\")\n"
+               "              #t)\n"
+               "    #:stop (lambda _\n"
+               "             (run-command \"/usr/sbin/service\" script-name \"onestop\")\n"
+               "             #f)\n"
+               "    #:respawn? #f))\n\n")
+              ""))
+         (pid1-services
+          (if pid1?
+              (string-append
+               (if start-sshd?
+                   "  (freebsd-rc-service '(netif) \"netif\"\n"
+                   "")
+               (if start-sshd?
+                   "    #:requirement '(fruix-logger)\n"
+                   "")
+               (if start-sshd?
+                   "    #:documentation \"Bring up FreeBSD networking from rc.conf.\")\n"
+                   "")
+               (if start-sshd?
+                   "  (freebsd-rc-service '(sshd) \"sshd\"\n"
+                   "")
+               (if start-sshd?
+                   "    #:requirement '(netif)\n"
+                   "")
+               (if start-sshd?
+                   "    #:documentation \"Start OpenSSH under Shepherd PID 1.\")\n"
+                   ""))
+              "")))
+    (string-append
+     "(use-modules (shepherd service)\n"
+     "             (ice-9 ftw)\n"
+     "             (ice-9 popen))\n\n"
+     "(define ready-marker \"" ready-marker "\")\n\n"
+     "(define (mkdir-p* dir)\n"
+     "  (unless (or (string=? dir \"\")\n"
+     "              (string=? dir \"/\")\n"
+     "              (file-exists? dir))\n"
+     "    (mkdir-p* (dirname dir))\n"
+     "    (mkdir dir)))\n\n"
+     "(define (ensure-parent-directory file)\n"
+     "  (mkdir-p* (dirname file)))\n\n"
+     pid1-helpers
+     "(register-services\n"
+     " (list\n"
+     "  (service '(fruix-logger)\n"
+     "    #:documentation \"Append a boot trace line for Fruix.\"\n"
+     "    #:start (lambda _\n"
+     "              (ensure-parent-directory \"/var/log/fruix-shepherd.log\")\n"
+     "              (let ((port (open-file \"/var/log/fruix-shepherd.log\" \"a\")))\n"
+     "                (display \"fruix-shepherd-started\\n\" port)\n"
+     "                (close-port port))\n"
+     "              #t)\n"
+     "    #:stop (lambda _ #f)\n"
+     "    #:respawn? #f)\n"
+     pid1-services
+     "  (service '(fruix-ready)\n"
+     "    #:documentation \"Write the Fruix ready marker.\"\n"
+     "    #:requirement " ready-requirements "\n"
+     "    #:start (lambda _\n"
+     "              (ensure-parent-directory ready-marker)\n"
+     "              (call-with-output-file ready-marker\n"
+     "                (lambda (port) (display \"ready\" port)))\n"
+     "              #t)\n"
+     "    #:stop (lambda _ #f)\n"
+     "    #:respawn? #f)))\n\n"
+     "(start-service (lookup-service 'fruix-ready))\n")))
+
+(define (render-activation-rc-script)
+  (string-append
+   "#!/bin/sh\n"
+   "# PROVIDE: fruix_activate\n"
+   "# REQUIRE: FILESYSTEMS\n"
+   "# BEFORE: LOGIN sshd fruix_shepherd\n"
+   "# KEYWORD: shutdown\n\n"
+   ". /etc/rc.subr\n\n"
+   "name=fruix_activate\n"
+   "rcvar=fruix_activate_enable\n"
+   ": ${fruix_activate_enable:=YES}\n"
+   "start_cmd=fruix_activate_start\n"
+   "stop_cmd=:\n\n"
+   "fruix_activate_start()\n"
+   "{\n"
+   "  /run/current-system/activate\n"
+   "}\n\n"
+   "load_rc_config $name\n"
+   "run_rc_command \"$1\"\n"))
+
+(define (render-rc-script shepherd-store guile-store guile-extra-store)
+  (let ((ld-library-path (string-append guile-extra-store "/lib:"
+                                        guile-store "/lib:/usr/local/lib"))
+        (guile-system-path
+         (string-append guile-store "/share/guile/3.0:"
+                        guile-store "/share/guile/site/3.0:"
+                        guile-store "/share/guile/site:"
+                        guile-store "/share/guile"))
+        (guile-load-path (string-append shepherd-store "/share/guile/site/3.0:"
+                                        guile-extra-store "/share/guile/site/3.0"))
+        (guile-system-compiled-path
+         (string-append guile-store "/lib/guile/3.0/ccache:"
+                        guile-store "/lib/guile/3.0/site-ccache"))
+        (guile-load-compiled-path
+         (string-append shepherd-store "/lib/guile/3.0/site-ccache:"
+                        guile-extra-store "/lib/guile/3.0/site-ccache"))
+        (guile-system-extensions-path (string-append guile-store "/lib/guile/3.0/extensions"))
+        (guile-extensions-path (string-append guile-extra-store "/lib/guile/3.0/extensions")))
+    (string-append
+     "#!/bin/sh\n"
+     "# PROVIDE: fruix_shepherd\n"
+     "# REQUIRE: FILESYSTEMS fruix_activate\n"
+     "# BEFORE: LOGIN\n"
+     "# KEYWORD: shutdown\n\n"
+     ". /etc/rc.subr\n\n"
+     "name=fruix_shepherd\n"
+     "rcvar=fruix_shepherd_enable\n"
+     ": ${fruix_shepherd_enable:=YES}\n"
+     "pidfile=/var/run/shepherd.pid\n"
+     "socket=/var/run/shepherd.sock\n"
+     "config=/run/current-system/shepherd/init.scm\n"
+     "logfile=/var/log/shepherd.log\n"
+     "command=" shepherd-store "/bin/shepherd\n"
+     "start_cmd=fruix_shepherd_start\n"
+     "stop_cmd=fruix_shepherd_stop\n"
+     "status_cmd=fruix_shepherd_status\n\n"
+     "fruix_shepherd_start()\n"
+     "{\n"
+     "  /usr/sbin/daemon -c -f -p \"$pidfile\" -o /var/log/shepherd-bootstrap.out /usr/bin/env \\\n"
+     "      LANG='C.UTF-8' LC_ALL='C.UTF-8' \\\n"
+     "      LD_LIBRARY_PATH='" ld-library-path "' \\\n"
+     "      GUILE_SYSTEM_PATH='" guile-system-path "' \\\n"
+     "      GUILE_LOAD_PATH='" guile-load-path "' \\\n"
+     "      GUILE_SYSTEM_COMPILED_PATH='" guile-system-compiled-path "' \\\n"
+     "      GUILE_LOAD_COMPILED_PATH='" guile-load-compiled-path "' \\\n"
+     "      GUILE_SYSTEM_EXTENSIONS_PATH='" guile-system-extensions-path "' \\\n"
+     "      GUILE_EXTENSIONS_PATH='" guile-extensions-path "' \\\n"
+     "      " guile-store "/bin/guile --no-auto-compile " shepherd-store "/bin/shepherd -I -s \"$socket\" -c \"$config\" -l \"$logfile\"\n"
+     "  for _try in 1 2 3 4 5 6 7 8 9 10; do\n"
+     "    [ -f \"$pidfile\" ] && [ -S \"$socket\" ] && return 0\n"
+     "    sleep 1\n"
+     "  done\n"
+     "  return 1\n"
+     "}\n\n"
+     "fruix_shepherd_stop()\n"
+     "{\n"
+     "  env LANG='C.UTF-8' LC_ALL='C.UTF-8' \\\n"
+     "      LD_LIBRARY_PATH='" ld-library-path "' \\\n"
+     "      GUILE_SYSTEM_PATH='" guile-system-path "' \\\n"
+     "      GUILE_LOAD_PATH='" guile-load-path "' \\\n"
+     "      GUILE_SYSTEM_COMPILED_PATH='" guile-system-compiled-path "' \\\n"
+     "      GUILE_LOAD_COMPILED_PATH='" guile-load-compiled-path "' \\\n"
+     "      GUILE_SYSTEM_EXTENSIONS_PATH='" guile-system-extensions-path "' \\\n"
+     "      GUILE_EXTENSIONS_PATH='" guile-extensions-path "' \\\n"
+     "      " guile-store "/bin/guile --no-auto-compile " shepherd-store "/bin/herd -s \"$socket\" stop root >/dev/null 2>&1 || true\n"
+     "  for _try in 1 2 3 4 5 6 7 8 9 10; do\n"
+     "    [ ! -f \"$pidfile\" ] && return 0\n"
+     "    sleep 1\n"
+     "  done\n"
+     "  kill \"$(cat \"$pidfile\")\" >/dev/null 2>&1 || true\n"
+     "  rm -f \"$pidfile\"\n"
+     "  return 0\n"
+     "}\n\n"
+     "fruix_shepherd_status()\n"
+     "{\n"
+     "  [ -f \"$pidfile\" ] && kill -0 \"$(cat \"$pidfile\")\" >/dev/null 2>&1\n"
+     "}\n\n"
+     "load_rc_config $name\n"
+     "run_rc_command \"$1\"\n")))
+
+
+(define* (operating-system-generated-files os #:key guile-store guile-extra-store shepherd-store)
+  (append
+   `(("boot/loader.conf" . ,(render-loader-conf os))
+     ("etc/rc.conf" . ,(render-rc.conf os))
+     ("etc/fstab" . ,(render-fstab os))
+     ("etc/hosts" . ,(render-hosts os))
+     ("etc/passwd" . ,(render-passwd os))
+     ("etc/master.passwd" . ,(render-master-passwd os))
+     ("etc/group" . ,(render-group os))
+     ("etc/login.conf" . ,(render-login-conf))
+     ("etc/shells" . ,(render-shells os))
+     ("etc/motd" . ,(render-motd os))
+     ("etc/ttys" . ,(render-ttys))
+     ("activate" . ,(render-activation-script os
+                                                #:guile-store guile-store
+                                                #:guile-extra-store guile-extra-store
+                                                #:shepherd-store shepherd-store))
+     ("shepherd/init.scm" . ,(render-shepherd-config os)))
+   (if (pid1-init-mode? os)
+       `(("boot/fruix-pid1" . ,(render-pid1-script os shepherd-store guile-store guile-extra-store)))
+       '())
+   (if (sshd-enabled? os)
+       `(("etc/ssh/sshd_config" . ,(render-sshd-config os)))
+       '())
+   (if (null? (operating-system-root-authorized-keys os))
+       '()
+       `(("root/.ssh/authorized_keys" . ,(render-root-authorized-keys os))))))
+

modules/fruix/system/freebsd/source.scm

@@ -0,0 +1,203 @@
+(define-module (fruix system freebsd source)
+  #:use-module (fruix packages freebsd)
+  #:use-module (fruix system freebsd model)
+  #:use-module (fruix system freebsd utils)
+  #:use-module (guix build utils)
+  #:use-module (srfi srfi-13)
+  #:export (materialize-freebsd-source
+            freebsd-source-materialization-spec))
+
+(define freebsd-source-materializer-version "2")
+
+(define (string-downcase* value)
+  (list->string (map char-downcase (string->list value))))
+
+(define (safe-name-fragment value)
+  (let* ((text (if (and (string? value) (not (string-null? value))) value "source"))
+         (chars (map (lambda (ch)
+                       (if (or (char-alphabetic? ch)
+                               (char-numeric? ch)
+                               (memv ch '(#\- #\_ #\.)))
+                           ch
+                           #\-))
+                     (string->list text))))
+    (list->string chars)))
+
+(define (freebsd-source-manifest source effective-source identity)
+  (string-append
+   "materializer-version=" freebsd-source-materializer-version "\n"
+   "declared-source=\n"
+   (object->string (freebsd-source-spec source))
+   "\neffective-source=\n"
+   (object->string (freebsd-source-spec effective-source))
+   "\nidentity=\n"
+   (object->string identity)))
+
+(define (ensure-git-source-cache source cache-dir)
+  (let* ((url (freebsd-source-url source))
+         (repo-dir (string-append cache-dir "/git/"
+                                  (string-hash (string-append "git:" url))
+                                  ".git")))
+    (mkdir-p (dirname repo-dir))
+    (unless (file-exists? repo-dir)
+      (unless (zero? (system* "git" "init" "--quiet" "--bare" repo-dir))
+        (error "failed to initialize git source cache" repo-dir))
+      (unless (zero? (system* "git" "-C" repo-dir "remote" "add" "origin" url))
+        (error "failed to add git source remote" url)))
+    (let ((current-url (safe-command-output "git" "-C" repo-dir "remote" "get-url" "origin")))
+      (unless (and current-url (string=? current-url url))
+        (unless (zero? (system* "git" "-C" repo-dir "remote" "set-url" "origin" url))
+          (error "failed to update git source remote" url))))
+    repo-dir))
+
+(define (resolve-git-freebsd-source source cache-dir)
+  (let* ((selector (or (freebsd-source-commit source)
+                       (freebsd-source-ref source)
+                       (error "git freebsd source requires a ref or commit" source)))
+         (repo-dir (ensure-git-source-cache source cache-dir)))
+    (unless (zero? (system* "git" "-C" repo-dir "fetch" "--quiet" "--depth" "1" "origin" selector))
+      (error "failed to fetch git freebsd source" selector))
+    (let ((resolved-commit (command-output "git" "-C" repo-dir "rev-parse" "FETCH_HEAD")))
+      `((cache-path . ,repo-dir)
+        (effective-source . ,(freebsd-source #:name (freebsd-source-name source)
+                                             #:kind 'git
+                                             #:url (freebsd-source-url source)
+                                             #:ref (freebsd-source-ref source)
+                                             #:commit resolved-commit
+                                             #:sha256 #f))
+        (identity . ((resolved-commit . ,resolved-commit)))
+        (populate-tree . ,(lambda (tree-root)
+                            (let ((archive-path (string-append (dirname tree-root) "/git-export.tar")))
+                              (unless (zero? (system* "git" "-C" repo-dir "archive"
+                                                      "--format=tar" "-o" archive-path resolved-commit))
+                                (error "failed to archive git freebsd source" resolved-commit))
+                              (unless (zero? (system* "tar" "-xpf" archive-path "-C" tree-root))
+                                (error "failed to extract archived git freebsd source" archive-path))
+                              (delete-path-if-exists archive-path))))))))
+
+(define (normalize-expected-sha256 source)
+  (let ((sha256 (freebsd-source-sha256 source)))
+    (and sha256 (string-downcase* sha256))))
+
+(define (resolve-txz-freebsd-source source cache-dir)
+  (let* ((url (freebsd-source-url source))
+         (expected-sha256 (or (normalize-expected-sha256 source)
+                              (error "src-txz freebsd source requires sha256 for materialization" source)))
+         (archive-path (string-append cache-dir "/archives/"
+                                      (string-hash (string-append "txz:" url))
+                                      "-src.txz")))
+    (mkdir-p (dirname archive-path))
+    (when (file-exists? archive-path)
+      (let ((actual (string-downcase* (file-hash archive-path))))
+        (unless (string=? actual expected-sha256)
+          (delete-file archive-path))))
+    (unless (file-exists? archive-path)
+      (unless (zero? (system* "fetch" "-q" "-o" archive-path url))
+        (error "failed to download FreeBSD src.txz source" url)))
+    (let ((actual-sha256 (string-downcase* (file-hash archive-path))))
+      (unless (string=? actual-sha256 expected-sha256)
+        (error "downloaded src.txz hash mismatch" url expected-sha256 actual-sha256))
+      `((cache-path . ,archive-path)
+        (effective-source . ,(freebsd-source #:name (freebsd-source-name source)
+                                             #:kind 'src-txz
+                                             #:url url
+                                             #:path #f
+                                             #:ref #f
+                                             #:commit #f
+                                             #:sha256 actual-sha256))
+        (identity . ((archive-sha256 . ,actual-sha256)))
+        (populate-tree . ,(lambda (tree-root)
+                            (unless (zero? (system* "tar" "-xpf" archive-path "-C" tree-root))
+                              (error "failed to extract FreeBSD src.txz source" archive-path))))))))
+
+(define (resolve-local-freebsd-source source)
+  (let* ((path (freebsd-source-path source))
+         (tree-sha256 (native-build-source-tree-sha256 path)))
+    `((cache-path . #f)
+      (effective-source . ,(freebsd-source #:name (freebsd-source-name source)
+                                           #:kind 'local-tree
+                                           #:url #f
+                                           #:path path
+                                           #:ref #f
+                                           #:commit #f
+                                           #:sha256 tree-sha256))
+      (identity . ((tree-sha256 . ,tree-sha256)))
+      (populate-tree . ,(lambda (tree-root)
+                          (copy-tree-contents path tree-root))))))
+
+(define (detect-materialized-source-relative-root tree-root)
+  (cond
+   ((file-exists? (string-append tree-root "/Makefile"))
+    "tree")
+   ((file-exists? (string-append tree-root "/usr/src/Makefile"))
+    "tree/usr/src")
+   (else
+    "tree")))
+
+(define* (materialize-freebsd-source source #:key
+                                    (store-dir "/frx/store")
+                                    (cache-dir "/frx/var/cache/fruix/freebsd-source"))
+  (validate-freebsd-source source)
+  (let* ((resolution (case (freebsd-source-kind source)
+                       ((local-tree)
+                        (resolve-local-freebsd-source source))
+                       ((git)
+                        (resolve-git-freebsd-source source cache-dir))
+                       ((src-txz)
+                        (resolve-txz-freebsd-source source cache-dir))
+                       (else
+                        (error "unsupported freebsd source kind" (freebsd-source-kind source)))))
+         (effective-source (assoc-ref resolution 'effective-source))
+         (identity (assoc-ref resolution 'identity))
+         (manifest (freebsd-source-manifest source effective-source identity))
+         (hash (string-hash manifest))
+         (output-path (string-append store-dir "/" hash "-freebsd-source-"
+                                     (safe-name-fragment (freebsd-source-name source))))
+         (info-file (string-append output-path "/.freebsd-source-info.scm"))
+         (cache-path (assoc-ref resolution 'cache-path))
+         (populate-tree (assoc-ref resolution 'populate-tree)))
+    (unless (file-exists? output-path)
+      (let* ((temp-output (string-append output-path ".tmp"))
+             (temp-tree-root (string-append temp-output "/tree")))
+        (delete-path-if-exists temp-output)
+        (mkdir-p temp-tree-root)
+        (populate-tree temp-tree-root)
+        (let* ((relative-root (detect-materialized-source-relative-root temp-tree-root))
+               (source-root (string-append output-path "/" relative-root))
+               (temp-source-root (string-append temp-output "/" relative-root))
+               (tree-sha256 (native-build-source-tree-sha256 temp-source-root)))
+          (write-file (string-append temp-output "/.references") "")
+          (write-file (string-append temp-output "/.fruix-source") manifest)
+          (write-file (string-append temp-output "/.freebsd-source-info.scm")
+                      (object->string
+                       `((materializer-version . ,freebsd-source-materializer-version)
+                         (declared-source . ,(freebsd-source-spec source))
+                         (effective-source . ,(freebsd-source-spec effective-source))
+                         (identity . ,identity)
+                         (source-store . ,output-path)
+                         (source-root . ,source-root)
+                         (source-tree-sha256 . ,tree-sha256)
+                         (cache-path . ,cache-path)))))
+        (rename-file temp-output output-path)))
+    (call-with-input-file info-file
+      (lambda (port)
+        (let* ((info (read port))
+               (effective (assoc-ref info 'effective-source)))
+          `((source-store-path . ,output-path)
+            (source-root . ,(assoc-ref info 'source-root))
+            (source-info-file . ,info-file)
+            (source-tree-sha256 . ,(assoc-ref info 'source-tree-sha256))
+            (cache-path . ,(assoc-ref info 'cache-path))
+            (effective-source . ,effective)
+            (effective-commit . ,(assoc-ref effective 'commit))
+            (effective-sha256 . ,(assoc-ref effective 'sha256))))))))
+
+
+(define (freebsd-source-materialization-spec result)
+  `((source-store-path . ,(assoc-ref result 'source-store-path))
+    (source-root . ,(assoc-ref result 'source-root))
+    (source-info-file . ,(assoc-ref result 'source-info-file))
+    (source-tree-sha256 . ,(assoc-ref result 'source-tree-sha256))
+    (cache-path . ,(assoc-ref result 'cache-path))
+    (effective-source . ,(assoc-ref result 'effective-source))))
+

modules/fruix/system/freebsd/utils.scm

@@ -0,0 +1,243 @@
+(define-module (fruix system freebsd utils)
+  #:use-module (guix build utils)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 hash-table)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-13)
+  #:use-module (rnrs io ports)
+  #:export (getenv*
+            trim-trailing-newlines
+            command-output
+            safe-command-output
+            write-file
+            string-hash
+            file-hash
+            directory-entries
+            path-signature
+            install-plan-signature
+            native-build-source-tree-sha256
+            copy-regular-file
+            copy-node
+            materialize-plan-entry
+            delete-path-if-exists
+            stage-tree-into-output
+            string-replace-all
+            rewrite-text-file
+            delete-file-if-exists
+            copy-tree-contents
+            path-basename
+            read-lines
+            run-command
+            store-reference-closure
+            copy-store-items-into-rootfs
+            copy-rootfs-for-image
+            mktemp-directory))
+
+(define (getenv* name default)
+  (or (getenv name) default))
+
+(define (trim-trailing-newlines str)
+  (let loop ((len (string-length str)))
+    (if (and (> len 0)
+             (char=? (string-ref str (- len 1)) #\newline))
+        (loop (- len 1))
+        (substring str 0 len))))
+
+(define (command-output program . args)
+  (let* ((port   (apply open-pipe* OPEN_READ program args))
+         (output (get-string-all port))
+         (status (close-pipe port)))
+    (unless (zero? status)
+      (error (format #f "command failed: ~a ~s => ~a" program args status)))
+    (trim-trailing-newlines output)))
+
+(define (safe-command-output program . args)
+  (false-if-exception (apply command-output program args)))
+
+(define (write-file path content)
+  (mkdir-p (dirname path))
+  (call-with-output-file path
+    (lambda (port)
+      (display content port))))
+
+(define (string-hash text)
+  (let* ((tmp (string-append (getenv* "TMPDIR" "/tmp") "/fruix-system-hash.txt")))
+    (write-file tmp text)
+    (command-output "sha256" "-q" tmp)))
+
+(define (file-hash path)
+  (command-output "sha256" "-q" path))
+
+
+(define (directory-entries path)
+  (sort (filter (lambda (entry)
+                  (not (member entry '("." ".."))))
+                (scandir path))
+        string<?))
+
+(define (path-signature path)
+  (let ((st (lstat path)))
+    (case (stat:type st)
+      ((regular)
+       (string-append "file:" path ":" (file-hash path)))
+      ((symlink)
+       (string-append "symlink:" path ":" (readlink path)))
+      ((directory)
+       (string-join
+        (cons (string-append "directory:" path)
+              (apply append
+                     (map (lambda (entry)
+                            (list (path-signature (string-append path "/" entry))))
+                          (directory-entries path))))
+        "\n"))
+      (else
+       (string-append "other:" path ":" (symbol->string (stat:type st)))))))
+
+(define (install-plan-signature entry)
+  (match entry
+    (('file source target)
+     (string-append "file-target:" target "\n" (path-signature source)))
+    (('directory source target)
+     (string-append "directory-target:" target "\n" (path-signature source)))
+    (_
+     (error (format #f "unsupported install plan entry: ~s" entry)))))
+
+(define (native-build-source-tree-sha256 source-root)
+  (let* ((mtree-output (command-output "mtree" "-c" "-k" "type,link,size,mode,sha256digest" "-p" source-root))
+         (stable-lines (filter (lambda (line)
+                                 (not (string-prefix? "#" line)))
+                               (string-split mtree-output #\newline))))
+    (string-hash (string-join stable-lines "\n"))))
+
+(define (copy-regular-file source destination)
+  (let ((mode (stat:perms (stat source))))
+    (copy-file source destination)
+    (chmod destination mode)))
+
+(define (copy-node source destination)
+  (let ((kind (stat:type (lstat source))))
+    (mkdir-p (dirname destination))
+    (case kind
+      ((directory)
+       (mkdir-p destination)
+       (for-each (lambda (entry)
+                   (copy-node (string-append source "/" entry)
+                              (string-append destination "/" entry)))
+                 (directory-entries source)))
+      ((symlink)
+       (symlink (readlink source) destination))
+      (else
+       (copy-regular-file source destination)))))
+
+(define (materialize-plan-entry output-path entry)
+  (match entry
+    (('file source target)
+     (copy-node source (string-append output-path "/" target)))
+    (('directory source target)
+     (copy-node source (string-append output-path "/" target)))
+    (_
+     (error (format #f "unsupported install plan entry: ~s" entry)))))
+
+(define (clear-file-flags path)
+  (false-if-exception (system* "chflags" "-R" "noschg,nouchg" path)))
+
+(define (delete-path-if-exists path)
+  (when (or (file-exists? path) (false-if-exception (readlink path)))
+    (clear-file-flags path)
+    (let ((kind (stat:type (lstat path))))
+      (case kind
+        ((directory) (delete-file-recursively path))
+        (else (delete-file path))))))
+
+(define (stage-tree-into-output stage-root output-path)
+  (mkdir-p output-path)
+  (for-each (lambda (entry)
+              (copy-node (string-append stage-root "/" entry)
+                         (string-append output-path "/" entry)))
+            (directory-entries stage-root)))
+
+
+(define (string-replace-all str old new)
+  (let ((old-len (string-length old)))
+    (let loop ((start 0) (chunks '()))
+      (let ((index (string-contains str old start)))
+        (if index
+            (loop (+ index old-len)
+                  (cons new
+                        (cons (substring str start index) chunks)))
+            (apply string-append
+                   (reverse (cons (substring str start) chunks))))))))
+
+(define (rewrite-text-file path replacements)
+  (when (file-exists? path)
+    (let* ((mode (stat:perms (stat path)))
+           (original (call-with-input-file path get-string-all))
+           (updated (fold (lambda (replacement text)
+                            (string-replace-all text (car replacement) (cdr replacement)))
+                          original
+                          replacements)))
+      (unless (string=? original updated)
+        (write-file path updated)
+        (chmod path mode)))))
+
+(define (delete-file-if-exists path)
+  (when (file-exists? path)
+    (delete-file path)))
+
+
+(define (copy-tree-contents source-root target-root)
+  (mkdir-p target-root)
+  (for-each (lambda (entry)
+              (copy-node (string-append source-root "/" entry)
+                         (string-append target-root "/" entry)))
+            (directory-entries source-root)))
+
+
+(define (path-basename path)
+  (let ((parts (filter (lambda (part) (not (string-null? part)))
+                       (string-split path #\/))))
+    (if (null? parts)
+        path
+        (last parts))))
+
+(define (read-lines path)
+  (if (file-exists? path)
+      (filter (lambda (line) (not (string-null? line)))
+              (string-split (call-with-input-file path get-string-all) #\newline))
+      '()))
+
+(define (run-command . args)
+  (let ((status (apply system* args)))
+    (unless (zero? status)
+      (error "command failed" args status))
+    #t))
+
+(define (store-reference-closure roots)
+  (let ((seen (make-hash-table))
+        (result '()))
+    (define (visit item)
+      (unless (hash-ref seen item #f)
+        (hash-set! seen item #t)
+        (set! result (cons item result))
+        (for-each visit (read-lines (string-append item "/.references")))))
+    (for-each visit roots)
+    (reverse result)))
+
+(define (copy-store-items-into-rootfs rootfs store-dir items)
+  (let ((store-root (string-append rootfs store-dir)))
+    (mkdir-p store-root)
+    (for-each (lambda (item)
+                (copy-node item (string-append store-root "/" (path-basename item))))
+              items)))
+
+(define (copy-rootfs-for-image source-rootfs image-rootfs)
+  (when (file-exists? image-rootfs)
+    (delete-file-recursively image-rootfs))
+  (copy-node source-rootfs image-rootfs))
+
+(define (mktemp-directory pattern)
+  (command-output "mktemp" "-d" pattern))
+

scripts/fruix.scm

@@ -19,15 +19,18 @@ 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\
+  installer                Materialize a bootable Fruix installer 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' or raw-file 'install' targets.\n\
-  --root-size SIZE         Root filesystem size for 'image' or 'install' (example: 6g).\n\
+  --disk-capacity SIZE     Disk capacity for 'image', 'installer', or raw-file 'install' targets.\n\
+  --root-size SIZE         Root filesystem size for 'image', 'installer', or 'install' (example: 6g).\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\
   --rootfs DIR             Rootfs target for 'rootfs'.\n\
 \n\
 Source actions:\n\
@@ -126,6 +129,7 @@ Common options:\n\
              (disk-capacity #f)
              (root-size #f)
              (target #f)
+             (install-target-device #f)
              (rootfs #f))
     (match args
       (()
@@ -138,37 +142,44 @@ Common options:\n\
            (disk-capacity . ,disk-capacity)
            (root-size . ,root-size)
            (target . ,target)
+           (install-target-device . ,install-target-device)
            (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 target rootfs))
+       (loop tail positional (option-value arg "--system=") store-dir disk-capacity root-size target install-target-device rootfs))
       (("--system" value . tail)
-       (loop tail positional value store-dir disk-capacity root-size target rootfs))
+       (loop tail positional value store-dir disk-capacity root-size target install-target-device rootfs))
       (((? (lambda (arg) (string-prefix? "--store=" arg)) arg) . tail)
-       (loop tail positional system-name (option-value arg "--store=") disk-capacity root-size target rootfs))
+       (loop tail positional system-name (option-value arg "--store=") disk-capacity root-size target install-target-device rootfs))
       (("--store" value . tail)
-       (loop tail positional system-name value disk-capacity root-size target rootfs))
+       (loop tail positional system-name value disk-capacity root-size target install-target-device rootfs))
       (((? (lambda (arg) (string-prefix? "--disk-capacity=" arg)) arg) . tail)
-       (loop tail positional system-name store-dir (option-value arg "--disk-capacity=") root-size target rootfs))
+       (loop tail positional system-name store-dir (option-value arg "--disk-capacity=") root-size target install-target-device rootfs))
       (("--disk-capacity" value . tail)
-       (loop tail positional system-name store-dir value root-size target rootfs))
+       (loop tail positional system-name store-dir value root-size target install-target-device rootfs))
       (((? (lambda (arg) (string-prefix? "--root-size=" arg)) arg) . tail)
-       (loop tail positional system-name store-dir disk-capacity (option-value arg "--root-size=") target rootfs))
+       (loop tail positional system-name store-dir disk-capacity (option-value arg "--root-size=") target install-target-device rootfs))
       (("--root-size" value . tail)
-       (loop tail positional system-name store-dir disk-capacity value target rootfs))
+       (loop tail positional system-name store-dir disk-capacity value target install-target-device 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))
+       (loop tail positional system-name store-dir disk-capacity root-size (option-value arg "--target=") install-target-device rootfs))
       (("--target" value . tail)
-       (loop tail positional system-name store-dir disk-capacity root-size value rootfs))
+       (loop tail positional system-name store-dir disk-capacity root-size value install-target-device rootfs))
+      (((? (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))
+      (("--install-target-device" value . tail)
+       (loop tail positional system-name store-dir disk-capacity root-size target value rootfs))
       (((? (lambda (arg) (string-prefix? "--rootfs=" arg)) arg) . tail)
-       (loop tail positional system-name store-dir disk-capacity root-size target (option-value arg "--rootfs=")))
+       (loop tail positional system-name store-dir disk-capacity root-size target install-target-device
+             (option-value arg "--rootfs=")))
       (("--rootfs" value . tail)
-       (loop tail positional system-name store-dir disk-capacity root-size target value))
+       (loop tail positional system-name store-dir disk-capacity root-size target install-target-device 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 target rootfs)))))
+       (loop tail (cons arg positional) system-name store-dir disk-capacity root-size target install-target-device rootfs)))))
 
 (define (parse-source-arguments action rest)
   (let loop ((args rest)
@@ -399,6 +410,72 @@ Common options:\n\
        (usr_src_newvers_sha256 . ,(assoc-ref host-provenance 'usr-src-newvers-sha256))
        (store_item_count . ,(length store-items))))))
 
+(define (emit-system-installer-metadata os-file resolved-symbol store-dir os result)
+  (let* ((installer-image-spec (assoc-ref result 'installer-image-spec))
+         (image-spec (assoc-ref result 'image-spec))
+         (store-items (assoc-ref result 'store-items))
+         (target-store-items (assoc-ref result 'target-store-items))
+         (installer-store-items (assoc-ref result 'installer-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 . "installer")
+       (os_file . ,os-file)
+       (system_variable . ,resolved-symbol)
+       (store_dir . ,store-dir)
+       (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 image-spec 'disk-capacity))
+       (root_size . ,(assoc-ref image-spec 'root-size))
+       (installer_host_name . ,(assoc-ref installer-image-spec 'installer-host-name))
+       (install_target_device . ,(assoc-ref result 'install-target-device))
+       (installer_state_path . ,(assoc-ref result 'installer-state-path))
+       (installer_log_path . ,(assoc-ref result 'installer-log-path))
+       (image_store_path . ,(assoc-ref result 'image-store-path))
+       (disk_image . ,(assoc-ref result 'disk-image))
+       (esp_image . ,(assoc-ref result 'esp-image))
+       (root_image . ,(assoc-ref result 'root-image))
+       (installer_closure_path . ,(assoc-ref result 'installer-closure-path))
+       (target_closure_path . ,(assoc-ref result 'target-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))
+       (target_store_item_count . ,(length target-store-items))
+       (installer_store_item_count . ,(length installer-store-items))))))
+
 (define (main argv)
   (let* ((parsed (parse-arguments argv))
          (command (assoc-ref parsed 'command))
@@ -410,10 +487,11 @@ Common options:\n\
              (disk-capacity (assoc-ref parsed 'disk-capacity))
              (root-size (assoc-ref parsed 'root-size))
              (target-opt (assoc-ref parsed 'target))
+             (install-target-device (assoc-ref parsed 'install-target-device))
              (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" "install" "rootfs"))
+        (unless (member action '("build" "image" "installer" "install" "rootfs"))
           (error "unknown system action" action))
         (let* ((os-file (match positional
                           ((file . _) file)
@@ -472,6 +550,17 @@ Common options:\n\
                                             #:shepherd-prefix shepherd-prefix
                                             #:root-size (or root-size "256m")
                                             #:disk-capacity disk-capacity)))
+                 ((string=? action "installer")
+                  (emit-system-installer-metadata
+                   os-file resolved-symbol store-dir os
+                   (materialize-installer-image os
+                                               #:store-dir store-dir
+                                               #:guile-prefix guile-prefix
+                                               #:guile-extra-prefix guile-extra-prefix
+                                               #:shepherd-prefix shepherd-prefix
+                                               #:install-target-device (or install-target-device "/dev/vtbd1")
+                                               #:root-size (or root-size "10g")
+                                               #:disk-capacity disk-capacity)))
                  ((string=? action "install")
                   (unless target
                     (error "install action requires TARGET or --target PATH"))

tests/system/phase18-installer-target-operating-system.scm.in

@@ -0,0 +1,91 @@
+(use-modules (fruix system freebsd)
+             (fruix packages freebsd))
+
+(define phase18-source
+  (freebsd-source
+   #:name "__SOURCE_NAME__"
+   #:kind 'git
+   #:ref "__SOURCE_REF__"
+   #:commit "__SOURCE_COMMIT__"))
+
+(define phase18-base
+  (freebsd-base
+   #:name "__BASE_NAME__"
+   #:version-label "__BASE_VERSION_LABEL__"
+   #:release "__BASE_RELEASE__"
+   #:branch "__BASE_BRANCH__"
+   #:source phase18-source
+   #:source-root "__DECLARED_SOURCE_ROOT__"
+   #:target "amd64"
+   #:target-arch "amd64"
+   #:kernconf "GENERIC"))
+
+(define phase18-target-operating-system
+  (operating-system
+   #:host-name "fruix-freebsd"
+   #:freebsd-base phase18-base
+   #:kernel (freebsd-native-kernel-for phase18-base)
+   #:bootloader (freebsd-native-bootloader-for phase18-base)
+   #:base-packages (freebsd-native-system-packages-for phase18-base)
+   #:groups (list (user-group #:name "wheel" #:gid 0 #:system? #t)
+                  (user-group #:name "sshd" #:gid 22 #:system? #t)
+                  (user-group #:name "_dhcp" #:gid 65 #:system? #t)
+                  (user-group #:name "operator" #:gid 1000 #:system? #f))
+   #:users (list (user-account #:name "root"
+                               #:uid 0
+                               #:group "wheel"
+                               #:comment "Charlie &"
+                               #:home "/root"
+                               #:shell "/bin/sh"
+                               #:system? #t)
+                 (user-account #:name "sshd"
+                               #:uid 22
+                               #:group "sshd"
+                               #:comment "Secure Shell Daemon"
+                               #:home "/var/empty"
+                               #:shell "/usr/sbin/nologin"
+                               #:system? #t)
+                 (user-account #:name "_dhcp"
+                               #:uid 65
+                               #:group "_dhcp"
+                               #:comment "dhcp programs"
+                               #:home "/var/empty"
+                               #:shell "/usr/sbin/nologin"
+                               #:system? #t)
+                 (user-account #:name "operator"
+                               #:uid 1000
+                               #:group "operator"
+                               #:supplementary-groups '("wheel")
+                               #:comment "Fruix Operator"
+                               #:home "/home/operator"
+                               #:shell "/bin/sh"
+                               #:system? #f))
+   #:file-systems (list (file-system #:device "/dev/gpt/fruix-root"
+                                     #:mount-point "/"
+                                     #:type "ufs"
+                                     #:options "rw"
+                                     #:needed-for-boot? #t)
+                        (file-system #:device "devfs"
+                                     #:mount-point "/dev"
+                                     #:type "devfs"
+                                     #:options "rw"
+                                     #:needed-for-boot? #t)
+                        (file-system #:device "tmpfs"
+                                     #:mount-point "/tmp"
+                                     #:type "tmpfs"
+                                     #:options "rw,size=64m"))
+   #:services '(shepherd ready-marker sshd)
+   #:loader-entries '(("autoboot_delay" . "1")
+                      ("boot_multicons" . "YES")
+                      ("boot_serial" . "YES")
+                      ("console" . "comconsole,vidconsole"))
+   #:rc-conf-entries '(("clear_tmp_enable" . "NO")
+                       ("hostid_enable" . "NO")
+                       ("sendmail_enable" . "NONE")
+                       ("sshd_enable" . "YES")
+                       ("ifconfig_xn0" . "SYNCDHCP")
+                       ("ifconfig_em0" . "SYNCDHCP")
+                       ("ifconfig_vtnet0" . "SYNCDHCP"))
+   #:init-mode 'freebsd-init+rc.d-shepherd
+   #:ready-marker "/var/lib/fruix/ready"
+   #:root-authorized-keys '("__ROOT_AUTHORIZED_KEY__")))

tests/system/run-phase18-installer-environment.sh

@@ -0,0 +1,399 @@
+#!/bin/sh
+set -eu
+
+project_root=${PROJECT_ROOT:-$(pwd)}
+script_dir=$(CDPATH= cd -- "$(dirname "$0")" && pwd)
+fruix_cmd=$project_root/bin/fruix
+os_template=${OS_TEMPLATE:-$script_dir/phase18-installer-target-operating-system.scm.in}
+system_name=${SYSTEM_NAME:-phase18-target-operating-system}
+store_dir=${STORE_DIR:-/frx/store}
+installer_disk_capacity=${INSTALLER_DISK_CAPACITY:-16g}
+installer_root_size=${INSTALLER_ROOT_SIZE:-14g}
+target_disk_capacity=${TARGET_DISK_CAPACITY:-12g}
+install_target_device=${INSTALL_TARGET_DEVICE:-/dev/vtbd1}
+qemu_smp=${QEMU_SMP:-2}
+installer_ssh_port=${INSTALLER_SSH_PORT:-10025}
+target_ssh_port=${TARGET_SSH_PORT:-10026}
+base_name=${BASE_NAME:-phase18-installer-target}
+base_version_label=${BASE_VERSION_LABEL:-15.0-STABLE-installer-target}
+base_release=${BASE_RELEASE:-15.0-STABLE}
+base_branch=${BASE_BRANCH:-stable/15}
+source_name=${SOURCE_NAME:-stable15-installer-target-source}
+source_ref=${SOURCE_REF:-stable/15}
+source_commit=${SOURCE_COMMIT:-332708a606f6bf0841c1d4a74c0d067f5640fe89}
+declared_source_root=${DECLARED_SOURCE_ROOT:-/var/empty/fruix-unused-source-root-installer-target}
+metadata_target=${METADATA_OUT:-}
+root_authorized_key_file=${ROOT_AUTHORIZED_KEY_FILE:-$HOME/.ssh/id_ed25519.pub}
+root_ssh_private_key_file=${ROOT_SSH_PRIVATE_KEY_FILE:-$HOME/.ssh/id_ed25519}
+
+[ -x "$fruix_cmd" ] || {
+  echo "fruix command is not executable: $fruix_cmd" >&2
+  exit 1
+}
+[ -f "$os_template" ] || {
+  echo "missing operating-system template: $os_template" >&2
+  exit 1
+}
+[ -f "$root_authorized_key_file" ] || {
+  echo "missing root authorized key file: $root_authorized_key_file" >&2
+  exit 1
+}
+[ -f "$root_ssh_private_key_file" ] || {
+  echo "missing root SSH private key file: $root_ssh_private_key_file" >&2
+  exit 1
+}
+command -v qemu-system-x86_64 >/dev/null 2>&1 || {
+  echo "qemu-system-x86_64 is required" >&2
+  exit 1
+}
+[ -f /usr/local/share/edk2-qemu/QEMU_UEFI_CODE-x86_64.fd ] || {
+  echo "missing QEMU UEFI firmware" >&2
+  exit 1
+}
+
+cleanup=0
+if [ -n "${WORKDIR:-}" ]; then
+  workdir=$WORKDIR
+  mkdir -p "$workdir"
+else
+  workdir=$(mktemp -d /tmp/fruix-phase18-installer.XXXXXX)
+  cleanup=1
+fi
+if [ "${KEEP_WORKDIR:-0}" -eq 1 ]; then
+  cleanup=0
+fi
+
+target_os_file=$workdir/phase18-installer-target-operating-system.scm
+installer_out=$workdir/installer.txt
+metadata_file=$workdir/phase18-installer-environment-metadata.txt
+installer_serial_log=$workdir/installer-serial.log
+target_serial_log=$workdir/target-serial.log
+installer_qemu_pidfile=$workdir/installer-qemu.pid
+target_qemu_pidfile=$workdir/target-qemu.pid
+installer_uefi_vars=$workdir/installer-vars.fd
+target_uefi_vars=$workdir/target-vars.fd
+installer_boot_image=$workdir/installer-boot.img
+target_image=$workdir/installed-target.img
+gpart_log=$workdir/gpart-show.txt
+mnt_esp=$workdir/mnt-esp
+mnt_root=$workdir/mnt-root
+md_unit=
+
+cleanup_workdir() {
+  if [ -f "$installer_qemu_pidfile" ]; then
+    sudo kill "$(sudo cat "$installer_qemu_pidfile")" >/dev/null 2>&1 || true
+  fi
+  if [ -f "$target_qemu_pidfile" ]; then
+    sudo kill "$(sudo cat "$target_qemu_pidfile")" >/dev/null 2>&1 || true
+  fi
+  if [ -n "$md_unit" ]; then
+    sudo umount "$mnt_esp" >/dev/null 2>&1 || true
+    sudo umount "$mnt_root" >/dev/null 2>&1 || true
+    sudo mdconfig -d -u "$md_unit" >/dev/null 2>&1 || true
+  fi
+  if [ "$cleanup" -eq 1 ]; then
+    rm -rf "$workdir" 2>/dev/null || sudo rm -rf "$workdir"
+  fi
+}
+trap cleanup_workdir EXIT INT TERM
+
+root_authorized_key=$(tr -d '\n' < "$root_authorized_key_file")
+sed \
+  -e "s|__BASE_NAME__|$base_name|g" \
+  -e "s|__BASE_VERSION_LABEL__|$base_version_label|g" \
+  -e "s|__BASE_RELEASE__|$base_release|g" \
+  -e "s|__BASE_BRANCH__|$base_branch|g" \
+  -e "s|__SOURCE_NAME__|$source_name|g" \
+  -e "s|__SOURCE_REF__|$source_ref|g" \
+  -e "s|__SOURCE_COMMIT__|$source_commit|g" \
+  -e "s|__DECLARED_SOURCE_ROOT__|$declared_source_root|g" \
+  -e "s|__ROOT_AUTHORIZED_KEY__|$root_authorized_key|g" \
+  "$os_template" > "$target_os_file"
+
+cp /usr/local/share/edk2-qemu/QEMU_UEFI_VARS-x86_64.fd "$installer_uefi_vars"
+cp /usr/local/share/edk2-qemu/QEMU_UEFI_VARS-x86_64.fd "$target_uefi_vars"
+truncate -s "$target_disk_capacity" "$target_image"
+mkdir -p "$mnt_esp" "$mnt_root"
+
+action_env() {
+  sudo env \
+    HOME="$HOME" \
+    GUILE_AUTO_COMPILE=0 \
+    FRUIX_FREEBSD_BUILD_JOBS="${FRUIX_FREEBSD_BUILD_JOBS:-8}" \
+    GUIX_SOURCE_DIR="${GUIX_SOURCE_DIR:-$HOME/repos/guix}" \
+    GUILE_BIN="${GUILE_BIN:-/tmp/guile-freebsd-validate-install/bin/guile}" \
+    GUILE_EXTRA_PREFIX="${GUILE_EXTRA_PREFIX:-/tmp/guile-gnutls-freebsd-validate-install}" \
+    SHEPHERD_PREFIX="${SHEPHERD_PREFIX:-/tmp/shepherd-freebsd-validate-install}" \
+    "$@"
+}
+
+action_env "$fruix_cmd" system installer "$target_os_file" \
+  --system "$system_name" \
+  --store "$store_dir" \
+  --install-target-device "$install_target_device" \
+  --disk-capacity "$installer_disk_capacity" \
+  --root-size "$installer_root_size" >"$installer_out"
+
+field() {
+  sed -n "s/^$1=//p" "$installer_out" | tail -n 1
+}
+
+image_store_path=$(field image_store_path)
+installer_disk_image=$(field disk_image)
+installer_esp_image=$(field esp_image)
+installer_root_image=$(field root_image)
+installer_closure_path=$(field installer_closure_path)
+target_closure_path=$(field target_closure_path)
+installer_host_name=$(field installer_host_name)
+install_target_device_out=$(field install_target_device)
+installer_state_path=$(field installer_state_path)
+installer_log_path=$(field installer_log_path)
+freebsd_source_kind_out=$(field freebsd_source_kind)
+freebsd_source_ref_out=$(field freebsd_source_ref)
+freebsd_source_commit_out=$(field freebsd_source_commit)
+freebsd_source_file=$(field freebsd_source_file)
+freebsd_source_materializations_file=$(field freebsd_source_materializations_file)
+materialized_source_store_count=$(field materialized_source_store_count)
+materialized_source_stores=$(field materialized_source_stores)
+host_base_store_count=$(field host_base_store_count)
+native_base_store_count=$(field native_base_store_count)
+native_base_stores=$(field native_base_stores)
+store_item_count=$(field store_item_count)
+target_store_item_count=$(field target_store_item_count)
+installer_store_item_count=$(field installer_store_item_count)
+store_layout_file=$(field store_layout_file)
+
+[ -d "$image_store_path" ] || { echo "missing installer image store path: $image_store_path" >&2; exit 1; }
+[ -f "$installer_disk_image" ] || { echo "missing installer disk image: $installer_disk_image" >&2; exit 1; }
+[ -f "$installer_esp_image" ] || { echo "missing installer ESP image: $installer_esp_image" >&2; exit 1; }
+[ -f "$installer_root_image" ] || { echo "missing installer root image: $installer_root_image" >&2; exit 1; }
+[ -n "$installer_closure_path" ] || { echo "missing installer closure path" >&2; exit 1; }
+[ -n "$target_closure_path" ] || { echo "missing target closure path" >&2; exit 1; }
+[ "$install_target_device_out" = "$install_target_device" ] || { echo "unexpected install target device: $install_target_device_out" >&2; exit 1; }
+[ "$installer_host_name" = fruix-freebsd-installer ] || { echo "unexpected installer host name: $installer_host_name" >&2; exit 1; }
+[ "$freebsd_source_kind_out" = git ] || { echo "unexpected source kind: $freebsd_source_kind_out" >&2; exit 1; }
+[ "$freebsd_source_ref_out" = "$source_ref" ] || { echo "unexpected source ref: $freebsd_source_ref_out" >&2; exit 1; }
+[ "$freebsd_source_commit_out" = "$source_commit" ] || { echo "unexpected source commit: $freebsd_source_commit_out" >&2; exit 1; }
+[ "$materialized_source_store_count" = 1 ] || { echo "unexpected materialized source store count: $materialized_source_store_count" >&2; exit 1; }
+[ "$host_base_store_count" = 0 ] || { echo "expected zero host base stores, got: $host_base_store_count" >&2; exit 1; }
+[ "$native_base_store_count" = 3 ] || { echo "expected three native base stores, got: $native_base_store_count" >&2; exit 1; }
+[ -f "$freebsd_source_file" ] || { echo "missing freebsd source file: $freebsd_source_file" >&2; exit 1; }
+[ -f "$freebsd_source_materializations_file" ] || { echo "missing source materializations file: $freebsd_source_materializations_file" >&2; exit 1; }
+[ -f "$store_layout_file" ] || { echo "missing store layout file: $store_layout_file" >&2; exit 1; }
+case "$materialized_source_stores" in
+  /frx/store/*-freebsd-source-$source_name) : ;;
+  *) echo "unexpected materialized source store path: $materialized_source_stores" >&2; exit 1 ;;
+esac
+[ "$store_item_count" -ge "$target_store_item_count" ] || { echo "combined store item count smaller than target store item count" >&2; exit 1; }
+[ "$installer_store_item_count" -ge 1 ] || { echo "expected installer store items" >&2; exit 1; }
+
+cp "$installer_disk_image" "$installer_boot_image"
+
+target_closure_base=$(basename "$target_closure_path")
+installer_closure_base=$(basename "$installer_closure_path")
+
+sudo qemu-system-x86_64 \
+  -machine q35,accel=tcg \
+  -cpu max \
+  -m 2048 \
+  -smp "$qemu_smp" \
+  -display none \
+  -serial "file:$installer_serial_log" \
+  -monitor none \
+  -pidfile "$installer_qemu_pidfile" \
+  -daemonize \
+  -drive if=pflash,format=raw,readonly=on,file=/usr/local/share/edk2-qemu/QEMU_UEFI_CODE-x86_64.fd \
+  -drive if=pflash,format=raw,file="$installer_uefi_vars" \
+  -drive if=virtio,format=raw,file="$installer_boot_image" \
+  -drive if=virtio,format=raw,file="$target_image" \
+  -netdev user,id=net0,hostfwd=tcp::${installer_ssh_port}-:22 \
+  -device virtio-net-pci,netdev=net0
+
+installer_guest() {
+  ssh -p "$installer_ssh_port" -i "$root_ssh_private_key_file" \
+    -o BatchMode=yes \
+    -o StrictHostKeyChecking=no \
+    -o UserKnownHostsFile=/dev/null \
+    -o LogLevel=ERROR \
+    -o ConnectTimeout=5 \
+    root@127.0.0.1 "$@"
+}
+
+installer_ssh_reached=0
+installer_state=missing
+for attempt in $(jot 150 1 150); do
+  if installer_guest 'service sshd onestatus >/dev/null 2>&1' >/dev/null 2>&1; then
+    installer_ssh_reached=1
+    installer_state=$(installer_guest "cat '$installer_state_path' 2>/dev/null || echo missing")
+    [ "$installer_state" = done ] && break
+  fi
+  sleep 2
+done
+
+[ "$installer_ssh_reached" = 1 ] || { echo "installer environment never became reachable over SSH" >&2; exit 1; }
+[ "$installer_state" = done ] || { echo "installer environment did not finish installation: $installer_state" >&2; exit 1; }
+
+installer_run_current_system=$(installer_guest 'readlink /run/current-system')
+installer_sshd_status=$(installer_guest 'service sshd onestatus >/dev/null 2>&1 && echo running || echo stopped')
+installer_activate_log=$(installer_guest 'cat /var/log/fruix-activate.log 2>/dev/null || true' | tr '\n' ' ')
+installer_log=$(installer_guest "cat '$installer_log_path' 2>/dev/null || true" | tr '\n' ' ')
+
+[ "$installer_run_current_system" = "/frx/store/$installer_closure_base" ] || { echo "unexpected installer current-system target: $installer_run_current_system" >&2; exit 1; }
+[ "$installer_sshd_status" = running ] || { echo "installer sshd is not running" >&2; exit 1; }
+case "$installer_activate_log" in
+  *fruix-activate:done*) : ;;
+  *) echo "installer activation log does not show success" >&2; exit 1 ;;
+esac
+case "$installer_log" in
+  *fruix-installer:done*) : ;;
+  *) echo "installer log does not show completion" >&2; exit 1 ;;
+esac
+
+sudo kill "$(sudo cat "$installer_qemu_pidfile")" >/dev/null 2>&1 || true
+rm -f "$installer_qemu_pidfile"
+sleep 2
+
+md=$(sudo mdconfig -a -t vnode -f "$target_image")
+md_unit=${md#md}
+sudo gpart show -lp "/dev/$md" >"$gpart_log"
+esp_fstype=$(sudo fstyp "/dev/${md}p1")
+root_fstype=$(sudo fstyp "/dev/${md}p2")
+[ "$esp_fstype" = msdosfs ] || { echo "unexpected target ESP filesystem: $esp_fstype" >&2; exit 1; }
+[ "$root_fstype" = ufs ] || { echo "unexpected target root filesystem: $root_fstype" >&2; exit 1; }
+
+sudo mount -t msdosfs "/dev/${md}p1" "$mnt_esp"
+sudo mount -t ufs -o ro "/dev/${md}p2" "$mnt_root"
+
+[ -f "$mnt_esp/EFI/BOOT/BOOTX64.EFI" ] || { echo "missing EFI boot file on installed target" >&2; exit 1; }
+target_run_current_system=$(readlink "$mnt_root/run/current-system")
+target_boot_loader=$(readlink "$mnt_root/boot/loader")
+install_metadata_host=$(cat "$mnt_root/var/lib/fruix/install.scm")
+[ "$target_run_current_system" = "/frx/store/$target_closure_base" ] || { echo "unexpected target /run/current-system target: $target_run_current_system" >&2; exit 1; }
+[ "$target_boot_loader" = /run/current-system/boot/loader ] || { echo "unexpected target boot loader link: $target_boot_loader" >&2; exit 1; }
+[ -d "$mnt_root/frx/store/$target_closure_base" ] || { echo "installed target closure missing from target root" >&2; exit 1; }
+case "$install_metadata_host" in
+  *"$target_closure_path"*) : ;;
+  *) echo "installed target metadata does not record target closure path" >&2; exit 1 ;;
+esac
+case "$install_metadata_host" in
+  *"$materialized_source_stores"*) : ;;
+  *) echo "installed target metadata does not record materialized source store" >&2; exit 1 ;;
+esac
+
+sudo umount "$mnt_esp"
+sudo umount "$mnt_root"
+sudo mdconfig -d -u "$md_unit"
+md_unit=
+
+sudo qemu-system-x86_64 \
+  -machine q35,accel=tcg \
+  -cpu max \
+  -m 2048 \
+  -smp "$qemu_smp" \
+  -display none \
+  -serial "file:$target_serial_log" \
+  -monitor none \
+  -pidfile "$target_qemu_pidfile" \
+  -daemonize \
+  -drive if=pflash,format=raw,readonly=on,file=/usr/local/share/edk2-qemu/QEMU_UEFI_CODE-x86_64.fd \
+  -drive if=pflash,format=raw,file="$target_uefi_vars" \
+  -drive if=virtio,format=raw,file="$target_image" \
+  -netdev user,id=net0,hostfwd=tcp::${target_ssh_port}-:22 \
+  -device virtio-net-pci,netdev=net0
+
+target_guest() {
+  ssh -p "$target_ssh_port" -i "$root_ssh_private_key_file" \
+    -o BatchMode=yes \
+    -o StrictHostKeyChecking=no \
+    -o UserKnownHostsFile=/dev/null \
+    -o LogLevel=ERROR \
+    -o ConnectTimeout=5 \
+    root@127.0.0.1 "$@"
+}
+
+for attempt in $(jot 120 1 120); do
+  if target_guest 'service sshd onestatus >/dev/null 2>&1' >/dev/null 2>&1; then
+    break
+  fi
+  sleep 2
+done
+
+target_run_current_system_guest=$(target_guest 'readlink /run/current-system')
+target_shepherd_status=$(target_guest '/usr/local/etc/rc.d/fruix-shepherd onestatus >/dev/null 2>&1 && echo running || echo stopped')
+target_sshd_status=$(target_guest 'service sshd onestatus >/dev/null 2>&1 && echo running || echo stopped')
+target_install_metadata_guest=$(target_guest 'cat /var/lib/fruix/install.scm')
+target_activate_log=$(target_guest 'cat /var/log/fruix-activate.log 2>/dev/null || true' | tr '\n' ' ')
+
+[ "$target_run_current_system_guest" = "/frx/store/$target_closure_base" ] || { echo "unexpected booted target current-system: $target_run_current_system_guest" >&2; exit 1; }
+[ "$target_shepherd_status" = running ] || { echo "fruix-shepherd is not running in booted target" >&2; exit 1; }
+[ "$target_sshd_status" = running ] || { echo "sshd is not running in booted target" >&2; exit 1; }
+case "$target_install_metadata_guest" in
+  *"$target_closure_path"*) : ;;
+  *) echo "booted target metadata does not record target closure path" >&2; exit 1 ;;
+esac
+case "$target_install_metadata_guest" in
+  *"$materialized_source_stores"*) : ;;
+  *) echo "booted target metadata does not record materialized source store" >&2; exit 1 ;;
+esac
+case "$target_activate_log" in
+  *fruix-activate:done*) : ;;
+  *) echo "booted target activation log does not show success" >&2; exit 1 ;;
+esac
+
+cat >"$metadata_file" <<EOF
+workdir=$workdir
+target_os_file=$target_os_file
+installer_image_store_path=$image_store_path
+installer_disk_image=$installer_disk_image
+installer_boot_image=$installer_boot_image
+installer_disk_capacity=$installer_disk_capacity
+installer_root_size=$installer_root_size
+target_image=$target_image
+target_disk_capacity=$target_disk_capacity
+install_target_device=$install_target_device
+qemu_smp=$qemu_smp
+freebsd_source_kind=$freebsd_source_kind_out
+freebsd_source_ref=$freebsd_source_ref_out
+freebsd_source_commit=$freebsd_source_commit_out
+freebsd_source_file=$freebsd_source_file
+freebsd_source_materializations_file=$freebsd_source_materializations_file
+materialized_source_store_count=$materialized_source_store_count
+materialized_source_store=$materialized_source_stores
+installer_closure_path=$installer_closure_path
+target_closure_path=$target_closure_path
+native_base_store_count=$native_base_store_count
+native_base_stores=$native_base_stores
+store_item_count=$store_item_count
+target_store_item_count=$target_store_item_count
+installer_store_item_count=$installer_store_item_count
+installer_state_path=$installer_state_path
+installer_log_path=$installer_log_path
+installer_state=$installer_state
+installer_run_current_system=$installer_run_current_system
+installer_sshd_status=$installer_sshd_status
+installer_serial_log=$installer_serial_log
+target_esp_fstype=$esp_fstype
+target_root_fstype=$root_fstype
+gpart_log=$gpart_log
+target_run_current_system=$target_run_current_system_guest
+target_shepherd_status=$target_shepherd_status
+target_sshd_status=$target_sshd_status
+target_serial_log=$target_serial_log
+installer_environment_boot=ok
+installer_environment_install=ok
+installed_target_boot=ok
+EOF
+
+if [ -n "$metadata_target" ]; then
+  mkdir -p "$(dirname "$metadata_target")"
+  cp "$metadata_file" "$metadata_target"
+fi
+
+printf 'PASS phase18-installer-environment\n'
+printf 'Work directory: %s\n' "$workdir"
+printf 'Metadata file: %s\n' "$metadata_file"
+if [ -n "$metadata_target" ]; then
+  printf 'Copied metadata to: %s\n' "$metadata_target"
+fi
+printf '%s\n' '--- metadata ---'
+cat "$metadata_file"