self/fruix
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Materialize FreeBSD source inputs

Browse Source
This commit is contained in:
Steffen
2026-04-03 12:07:37 +02:00
parent d89225fe11
commit 3f1793607d
8 changed files with 1116 additions and 213 deletions
Download Patch File Download Diff File Expand all files Collapse all files

71
docs/PROGRESS.md
View File

@@ -1,5 +1,76 @@
# Progress # Progress
## 2026-04-03 — Phase 16.2 completed: Fruix now materializes FreeBSD source inputs under its control
Completed work:
- added a new exported source materializer in `modules/fruix/system/freebsd.scm`:
- `materialize-freebsd-source`
- added cache-backed materialization for source kinds:
- `local-tree`
- `git`
- `src-txz`
- added cache locations under:
- `/frx/var/cache/fruix/freebsd-source/git`
- `/frx/var/cache/fruix/freebsd-source/archives`
- materialized source outputs now live in `/frx/store` as:
- `*-freebsd-source-*`
- each materialized source now records:
- declared source
- effective/resolved source
- source store path
- effective source root
- source tree sha256
- cache path
- added automatic effective-root detection so archive-backed sources that unpack as `usr/src/...` are still usable later:
- Git exports use `.../tree`
- `src.txz` archives use `.../tree/usr/src`
- added a new user-facing CLI path in `scripts/fruix.scm`:
- `fruix source materialize SOURCE-FILE`
- new source command options:
- `--source NAME`
- `--store DIR`
- `--cache DIR`
- `--help`
- source CLI now emits machine-readable metadata for:
- declared source fields
- materialized store path/root
- source tree hash
- cache path
- resolved Git commit
- verified archive sha256
- tightened `src-txz` validation so materialization now requires:
- URL
- sha256
- added validation artifacts:
- `tests/system/phase16-git-freebsd-source.scm.in`
- `tests/system/phase16-txz-freebsd-source.scm.in`
- `tests/system/run-phase16-source-materialization.sh`
- wrote:
- `docs/reports/phase16-source-materialization-freebsd.md`
Validation:
- `PASS phase16-source-materialization`
- `PASS phase16-declarative-source-build`
- verified Git source fetch/materialization from:
- `https://git.FreeBSD.org/src.git`
- ref: `stable/15`
- resolved commit during validation:
- `332708a606f6bf0841c1d4a74c0d067f5640fe89`
- verified canonical release archive fetch/materialization from:
- `https://download.freebsd.org/releases/amd64/15.0-RELEASE/src.txz`
- sha256:
- `83c3e8157b6d7afcae57167fda75693bf1e5f581ca149a6ecb2d398b71bdfab0`
- verified repeated materialization returns stable store paths for both the Git and `src.txz` cases
Current assessment:
- Phase 16.2 is complete
- Fruix can now fetch or materialize declared FreeBSD source trees into `/frx/store` with cache-backed provenance under `/frx/var/cache/fruix/freebsd-source`
- the next step is Phase 16.3:
- teach native FreeBSD kernel/world/runtime builds to consume these materialized source artifacts instead of ambient `/usr/src`
## 2026-04-03 — Phase 16.1 completed: FreeBSD source inputs are now explicit Fruix objects ## 2026-04-03 — Phase 16.1 completed: FreeBSD source inputs are now explicit Fruix objects
Completed work: Completed work:

9
docs/PROG_SUMMARY.md
View File

@@ -22,6 +22,11 @@ Completed milestones include:
- `freebsd-native-bootloader` - `freebsd-native-bootloader`
- `freebsd-native-runtime` - `freebsd-native-runtime`
- **Declarative FreeBSD base model**: the FreeBSD base is now an explicit system input via `freebsd-base`, not just an ambient property of the builder host. - **Declarative FreeBSD base model**: the FreeBSD base is now an explicit system input via `freebsd-base`, not just an ambient property of the builder host.
- **Declarative FreeBSD source model and materialization**: Fruix can now describe FreeBSD sources explicitly via `freebsd-source` and materialize them from:
- local source trees
- `https://git.FreeBSD.org/src.git`
- official `src.txz` archives such as `https://download.freebsd.org/releases/amd64/15.0-RELEASE/src.txz`
into `/frx/store`, with cache-backed provenance under `/frx/var/cache/fruix/freebsd-source`.
- **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. - **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 ## Major pain points now behind us
@@ -36,7 +41,7 @@ Completed milestones include:
## Major pain points still ahead ## 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. - **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.
- **Source reproducibility for the FreeBSD base**: the next major boundary is no longer host-copy boot/runtime assets; it is making source-tree selection/acquisition more reproducible and less tied to a single ambient `/usr/src`. - **Source-driven native base builds**: Fruix can now declare and materialize FreeBSD source inputs, but the validated native kernel/world/runtime build path still needs to consume those materialized source artifacts instead of ambient `/usr/src`.
- **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. - **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. - **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. - **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.
@@ -44,4 +49,4 @@ Completed milestones include:
## Bottom line ## 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`, and roll forward / back between declared base versions. The biggest remaining work is no longer “can this boot?” but “how reproducible and source-declarative can we make the native FreeBSD base path from here?” 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, and materialize declared FreeBSD source inputs into `/frx/store`. The biggest remaining work is no longer “can this boot?” but “how fully can the native FreeBSD base path be driven by fetched, pinned, reproducible source inputs and a real installation/deployment story?”

256
docs/reports/phase16-source-materialization-freebsd.md Normal file
View File

@@ -0,0 +1,256 @@
# Phase 16.2: materialize declarative FreeBSD source inputs under Fruix control
Date: 2026-04-03
## Goal
Phase 16.2 moves from merely *describing* FreeBSD source inputs to actually *materializing* them under Fruix control.
The objective in this subphase was not yet to switch the native base build path away from ambient `/usr/src`. Instead, it was to establish the missing fetch/materialization layer that later phases can consume.
That means Fruix now knows how to:
- fetch a Git-backed FreeBSD source declaration
- download and verify a `src.txz` declaration
- materialize the resulting source tree into `/frx/store`
- cache downloaded source state under `/frx/var/cache/fruix/freebsd-source`
- record stable source metadata for later native builds
## Implementation
### New source materializer in `modules/fruix/system/freebsd.scm`
Added:
- `materialize-freebsd-source`
and exported it for use by the Fruix CLI.
This materializer now supports all currently modeled source kinds:
- `local-tree`
- `git`
- `src-txz`
### Source artifacts are now first-class store objects
Materialized source outputs are now stored in paths of the form:
- `/frx/store/<hash>-freebsd-source-<name>`
Each source output contains:
- `tree/` or an auto-detected nested source root beneath it
- `.fruix-source`
- `.freebsd-source-info.scm`
- `.references`
The source info file records at least:
- declared source
- effective/resolved source
- materialized store path
- effective source root
- source tree SHA256
- cache path used to produce it
### Cache layout added under `/frx/var/cache/fruix/freebsd-source`
The new materializer caches downloaded source state under:
- `/frx/var/cache/fruix/freebsd-source/git/...`
- `/frx/var/cache/fruix/freebsd-source/archives/...`
Current behavior:
- Git sources use a cached bare repository
- `src.txz` sources use a cached archive file
- repeated materialization of the same resolved source identity reuses the same store output path
### Git source handling
Git materialization now:
- uses `https://git.FreeBSD.org/src.git`
- supports declarations by ref and/or commit
- fetches the selected ref/commit into a cached bare repository
- resolves refs to a concrete commit
- exports that commit into a store materialization
This means Fruix can now represent moving refs declaratively while still recording the exact resolved commit used for a given materialized source tree.
### `src.txz` source handling
`src.txz` materialization now:
- downloads the declared archive URL with `fetch`
- requires and verifies SHA256 for materialization
- extracts the archive into a store materialization
- records both the declared hash and the resulting source tree hash
For release archives, the canonical shorter URL form is now used in validation and documentation, for example:
- `https://download.freebsd.org/releases/amd64/15.0-RELEASE/src.txz`
rather than the longer doubled-architecture variant.
### Auto-detect the effective source root inside materialized trees
Git exports place the source tree directly at the materialized root.
Official `src.txz` archives instead unpack as:
- `usr/src/...`
inside the extracted directory tree.
To make this usable for later native builds, the materializer now auto-detects the effective source root and records it explicitly. For example:
- Git materialization root:
- `/frx/store/...-freebsd-source-stable15-git-ref/tree`
- `src.txz` materialization root:
- `/frx/store/...-freebsd-source-release15-src-txz/tree/usr/src`
### New user-facing CLI command
Added a new user-facing command path in `scripts/fruix.scm`:
- `fruix source materialize SOURCE-FILE`
with options:
- `--source NAME`
- `--store DIR`
- `--cache DIR`
- `--help`
The command emits machine-readable metadata including:
- declared source fields
- materialized store path
- effective source root
- source tree hash
- cache path
- resolved Git commit if applicable
- verified archive hash if applicable
This gives Phase 16.2 an operator-usable entry point rather than limiting it to internal Scheme helpers.
### Validation tightened for archive-backed sources
`src-txz` source validation now requires:
- URL
- SHA256
This is the right reproducibility boundary for archive downloads.
## Guix comparison
This step continues to mirror the most useful Guix source boundary without copying it mechanically:
- Guix models source objects with `origin`
- Git-backed origins use `git-reference`
Fruix's source materializer now plays a similar role for FreeBSD-specific source inputs:
- local tree snapshots
- FreeBSD Git refs/commits
- official `src.txz` archives
The key preserved idea is the same: source identity should become an explicit, recorded, materialized input rather than ambient host state.
## New files
Added:
- `tests/system/phase16-git-freebsd-source.scm.in`
- `tests/system/phase16-txz-freebsd-source.scm.in`
- `tests/system/run-phase16-source-materialization.sh`
## Validation
Passing run:
- `PASS phase16-source-materialization`
- workdir:
- `/tmp/fruix-phase16-source-materialization.QGuXi1`
### Git validation
Validated a Git declaration:
- name:
- `stable15-git-ref`
- URL:
- `https://git.FreeBSD.org/src.git`
- ref:
- `stable/15`
Resolved/materialized result:
```text
materialized_source_store=/frx/store/dd1cc6b5ffa95b4d0c0f269522d5739da05e0f4ae81b1b314221d28b49d1981f-freebsd-source-stable15-git-ref
materialized_source_root=/frx/store/dd1cc6b5ffa95b4d0c0f269522d5739da05e0f4ae81b1b314221d28b49d1981f-freebsd-source-stable15-git-ref/tree
materialized_source_tree_sha256=d0d8e085d913a511d7fa1ba410040eb697a4cef800f354a092c65249ab3c4eb4
materialized_source_cache_path=/frx/var/cache/fruix/freebsd-source/git/9d432c47301c356bd2cede3400de40870e0b541b276888e34c68b882b9b894c7.git
materialized_source_commit=332708a606f6bf0841c1d4a74c0d067f5640fe89
```
The harness also confirmed:
- repeated materialization returned the same store path
- the cached Git repository exists
- the materialized tree contains:
- `Makefile`
- `sys/conf/newvers.sh`
### `src.txz` validation
Validated an archive declaration:
- name:
- `release15-src-txz`
- URL:
- `https://download.freebsd.org/releases/amd64/15.0-RELEASE/src.txz`
- SHA256:
- `83c3e8157b6d7afcae57167fda75693bf1e5f581ca149a6ecb2d398b71bdfab0`
Resolved/materialized result:
```text
materialized_source_store=/frx/store/2e7857fb2c067b32acb482d048b8d1c2eeffdecd213108b3b0a4b2a87d56bc68-freebsd-source-release15-src-txz
materialized_source_root=/frx/store/2e7857fb2c067b32acb482d048b8d1c2eeffdecd213108b3b0a4b2a87d56bc68-freebsd-source-release15-src-txz/tree/usr/src
materialized_source_tree_sha256=afbe26f2213a19685fc2c3b875d26fab67e2cfcd605716cc66f669dabeaf7572
materialized_source_cache_path=/frx/var/cache/fruix/freebsd-source/archives/64ac7cc7d27435406995d63ef0b87ed0c485ce953ee8e9126127ca8f2a451d98-src.txz
materialized_source_sha256=83c3e8157b6d7afcae57167fda75693bf1e5f581ca149a6ecb2d398b71bdfab0
```
The harness also confirmed:
- repeated materialization returned the same store path
- the cached archive exists
- the effective materialized source root was detected as `tree/usr/src`
- that root contains:
- `Makefile`
- `sys/conf/newvers.sh`
### Regression check
Also re-ran:
- `PASS phase16-declarative-source-build`
This confirmed the new source materialization work did not break the earlier Phase 16.1 declarative source model path.
## Result
Phase 16.2 is complete.
Fruix can now fetch or materialize declared FreeBSD source inputs into `/frx/store` with cache-backed provenance under `/frx/var/cache/fruix/freebsd-source`.
The next step is now clear and narrower:
- teach native FreeBSD kernel/world/runtime builds to consume these materialized source artifacts instead of ambient `/usr/src`
That will be the real handoff from source acquisition to source-driven native base builds.

197
modules/fruix/system/freebsd.scm
View File

@@ -49,6 +49,7 @@
operating-system-ready-marker operating-system-ready-marker
operating-system-root-authorized-keys operating-system-root-authorized-keys
validate-operating-system validate-operating-system
materialize-freebsd-source
operating-system-closure-spec operating-system-closure-spec
operating-system-image-spec operating-system-image-spec
materialize-operating-system materialize-operating-system
@@ -716,6 +717,198 @@
(kernconf . ,(freebsd-base-kernconf base)) (kernconf . ,(freebsd-base-kernconf base))
(make-flags . ,(freebsd-base-make-flags base)))) (make-flags . ,(freebsd-base-make-flags base))))
(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 (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 (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 (duplicate-elements values) (define (duplicate-elements values)
(let loop ((rest values) (seen '()) (duplicates '())) (let loop ((rest values) (seen '()) (duplicates '()))
(match rest (match rest
@@ -747,7 +940,9 @@
(error "git freebsd source must declare a ref or commit" source))) (error "git freebsd source must declare a ref or commit" source)))
((src-txz) ((src-txz)
(unless (non-empty-string? (freebsd-source-url source)) (unless (non-empty-string? (freebsd-source-url source))
(error "src-txz freebsd source must declare a 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) #t)
(define (validate-operating-system os) (define (validate-operating-system os)

557
scripts/fruix.scm
View File

@@ -10,20 +10,34 @@
(define (usage code) (define (usage code)
(format (if (= code 0) #t (current-error-port)) (format (if (= code 0) #t (current-error-port))
"Usage: fruix system ACTION OS-FILE [OPTIONS]\n\ "Usage: fruix COMMAND ...\n\
\n\ \n\
Actions:\n\ Commands:\n\
build Materialize the Fruix system closure in /frx/store.\n\ system ACTION ... Build or materialize Fruix system artifacts.\n\
image Materialize the Fruix disk image in /frx/store.\n\ source ACTION ... Fetch or snapshot declarative FreeBSD source inputs.\n\
rootfs Materialize a rootfs tree at --rootfs DIR or ROOTFS-DIR.\n\
\n\ \n\
Options:\n\ System actions:\n\
--system NAME Scheme variable holding the operating-system object.\n\ build Materialize the Fruix system closure in /frx/store.\n\
--store DIR Store directory to use (default: /frx/store).\n\ image Materialize the Fruix disk image in /frx/store.\n\
--disk-capacity SIZE Disk capacity for 'image' (example: 30g).\n\ rootfs Materialize a rootfs tree at --rootfs DIR or ROOTFS-DIR.\n\
--root-size SIZE Root filesystem size for 'image' (example: 6g).\n\ \n\
--rootfs DIR Rootfs target for 'rootfs'.\n\ System options:\n\
--help Show this help.\n") --system NAME Scheme variable holding the operating-system object.\n\
--store DIR Store directory to use (default: /frx/store).\n\
--disk-capacity SIZE Disk capacity for 'image' (example: 30g).\n\
--root-size SIZE Root filesystem size for 'image' (example: 6g).\n\
--rootfs DIR Rootfs target for 'rootfs'.\n\
\n\
Source actions:\n\
materialize Materialize a declared FreeBSD source tree in /frx/store.\n\
\n\
Source options:\n\
--source NAME Scheme variable holding the freebsd-source object.\n\
--store DIR Store directory to use (default: /frx/store).\n\
--cache DIR Cache directory to use (default: /frx/var/cache/fruix/freebsd-source).\n\
\n\
Common options:\n\
--help Show this help.\n")
(exit code)) (exit code))
(define (option-value arg prefix) (define (option-value arg prefix)
@@ -48,6 +62,8 @@ Options:\n\
(define candidate-operating-system-symbols (define candidate-operating-system-symbols
'(operating-system '(operating-system
phase16-operating-system
phase15-operating-system
phase10-operating-system phase10-operating-system
phase9-operating-system phase9-operating-system
phase8-operating-system phase8-operating-system
@@ -55,6 +71,12 @@ Options:\n\
default-operating-system default-operating-system
os)) os))
(define candidate-freebsd-source-symbols
'(phase16-source
declared-source
source
src))
(define (resolve-operating-system-symbol module requested) (define (resolve-operating-system-symbol module requested)
(or requested (or requested
(find (lambda (symbol) (find (lambda (symbol)
@@ -63,6 +85,14 @@ Options:\n\
candidate-operating-system-symbols) candidate-operating-system-symbols)
(error "could not infer operating-system variable; use --system NAME"))) (error "could not infer operating-system variable; use --system NAME")))
(define (resolve-freebsd-source-symbol module requested)
(or requested
(find (lambda (symbol)
(let ((value (lookup-bound-value module symbol)))
(and value (freebsd-source? value))))
candidate-freebsd-source-symbols)
(error "could not infer freebsd-source variable; use --source NAME")))
(define (load-operating-system-from-file file requested-symbol) (define (load-operating-system-from-file file requested-symbol)
(unless (file-exists? file) (unless (file-exists? file)
(error "operating-system file does not exist" file)) (error "operating-system file does not exist" file))
@@ -75,6 +105,97 @@ Options:\n\
(validate-operating-system value) (validate-operating-system value)
(values value symbol))) (values value symbol)))
(define (load-freebsd-source-from-file file requested-symbol)
(unless (file-exists? file)
(error "freebsd-source file does not exist" file))
(primitive-load file)
(let* ((module (current-module))
(symbol (resolve-freebsd-source-symbol module requested-symbol))
(value (lookup-bound-value module symbol)))
(unless (and value (freebsd-source? value))
(error "resolved variable is not a freebsd-source" symbol))
(values value symbol)))
(define (parse-system-arguments action rest)
(let loop ((args rest)
(positional '())
(system-name #f)
(store-dir "/frx/store")
(disk-capacity #f)
(root-size #f)
(rootfs #f))
(match args
(()
(let ((positional (reverse positional)))
`((command . "system")
(action . ,action)
(positional . ,positional)
(system-name . ,system-name)
(store-dir . ,store-dir)
(disk-capacity . ,disk-capacity)
(root-size . ,root-size)
(rootfs . ,rootfs))))
(("--help")
(usage 0))
(((? (lambda (arg) (string-prefix? "--system=" arg)) arg) . tail)
(loop tail positional (option-value arg "--system=") store-dir disk-capacity root-size rootfs))
(("--system" value . tail)
(loop tail positional value store-dir disk-capacity root-size rootfs))
(((? (lambda (arg) (string-prefix? "--store=" arg)) arg) . tail)
(loop tail positional system-name (option-value arg "--store=") disk-capacity root-size rootfs))
(("--store" value . tail)
(loop tail positional system-name value disk-capacity root-size rootfs))
(((? (lambda (arg) (string-prefix? "--disk-capacity=" arg)) arg) . tail)
(loop tail positional system-name store-dir (option-value arg "--disk-capacity=") root-size rootfs))
(("--disk-capacity" value . tail)
(loop tail positional system-name store-dir value root-size rootfs))
(((? (lambda (arg) (string-prefix? "--root-size=" arg)) arg) . tail)
(loop tail positional system-name store-dir disk-capacity (option-value arg "--root-size=") rootfs))
(("--root-size" value . tail)
(loop tail positional system-name store-dir disk-capacity value rootfs))
(((? (lambda (arg) (string-prefix? "--rootfs=" arg)) arg) . tail)
(loop tail positional system-name store-dir disk-capacity root-size (option-value arg "--rootfs=")))
(("--rootfs" value . tail)
(loop tail positional system-name store-dir disk-capacity root-size value))
(((? (lambda (arg) (string-prefix? "--" arg)) arg) . _)
(error "unknown option" arg))
((arg . tail)
(loop tail (cons arg positional) system-name store-dir disk-capacity root-size rootfs)))))
(define (parse-source-arguments action rest)
(let loop ((args rest)
(positional '())
(source-name #f)
(store-dir "/frx/store")
(cache-dir "/frx/var/cache/fruix/freebsd-source"))
(match args
(()
(let ((positional (reverse positional)))
`((command . "source")
(action . ,action)
(positional . ,positional)
(source-name . ,source-name)
(store-dir . ,store-dir)
(cache-dir . ,cache-dir))))
(("--help")
(usage 0))
(((? (lambda (arg) (string-prefix? "--source=" arg)) arg) . tail)
(loop tail positional (option-value arg "--source=") store-dir cache-dir))
(("--source" value . tail)
(loop tail positional value store-dir cache-dir))
(((? (lambda (arg) (string-prefix? "--store=" arg)) arg) . tail)
(loop tail positional source-name (option-value arg "--store=") cache-dir))
(("--store" value . tail)
(loop tail positional source-name value cache-dir))
(((? (lambda (arg) (string-prefix? "--cache=" arg)) arg) . tail)
(loop tail positional source-name store-dir (option-value arg "--cache=")))
(("--cache" value . tail)
(loop tail positional source-name store-dir value))
(((? (lambda (arg) (string-prefix? "--" arg)) arg) . _)
(error "unknown option" arg))
((arg . tail)
(loop tail (cons arg positional) source-name store-dir cache-dir)))))
(define (parse-arguments argv) (define (parse-arguments argv)
(match argv (match argv
((_) ((_)
@@ -85,114 +206,217 @@ Options:\n\
(usage 0)) (usage 0))
((_ "system" "--help") ((_ "system" "--help")
(usage 0)) (usage 0))
((_ "source" "--help")
(usage 0))
((_ "system" action . rest) ((_ "system" action . rest)
(let loop ((args rest) (parse-system-arguments action rest))
(positional '()) ((_ "source" action . rest)
(system-name #f) (parse-source-arguments action rest))
(store-dir "/frx/store")
(disk-capacity #f)
(root-size #f)
(rootfs #f))
(match args
(()
(let ((positional (reverse positional)))
`((action . ,action)
(positional . ,positional)
(system-name . ,system-name)
(store-dir . ,store-dir)
(disk-capacity . ,disk-capacity)
(root-size . ,root-size)
(rootfs . ,rootfs))))
(("--help")
(usage 0))
(((? (lambda (arg) (string-prefix? "--system=" arg)) arg) . tail)
(loop tail positional (option-value arg "--system=") store-dir disk-capacity root-size rootfs))
(("--system" value . tail)
(loop tail positional value store-dir disk-capacity root-size rootfs))
(((? (lambda (arg) (string-prefix? "--store=" arg)) arg) . tail)
(loop tail positional system-name (option-value arg "--store=") disk-capacity root-size rootfs))
(("--store" value . tail)
(loop tail positional system-name value disk-capacity root-size rootfs))
(((? (lambda (arg) (string-prefix? "--disk-capacity=" arg)) arg) . tail)
(loop tail positional system-name store-dir (option-value arg "--disk-capacity=") root-size rootfs))
(("--disk-capacity" value . tail)
(loop tail positional system-name store-dir value root-size rootfs))
(((? (lambda (arg) (string-prefix? "--root-size=" arg)) arg) . tail)
(loop tail positional system-name store-dir disk-capacity (option-value arg "--root-size=") rootfs))
(("--root-size" value . tail)
(loop tail positional system-name store-dir disk-capacity value rootfs))
(((? (lambda (arg) (string-prefix? "--rootfs=" arg)) arg) . tail)
(loop tail positional system-name store-dir disk-capacity root-size (option-value arg "--rootfs=")))
(("--rootfs" value . tail)
(loop tail positional system-name store-dir disk-capacity root-size value))
(((? (lambda (arg) (string-prefix? "--" arg)) arg) . _)
(error "unknown option" arg))
((arg . tail)
(loop tail (cons arg positional) system-name store-dir disk-capacity root-size rootfs)))))
((_ . _) ((_ . _)
(usage 1)))) (usage 1))))
(define (emit-system-build-metadata os-file resolved-symbol store-dir os result)
(let* ((closure-path (assoc-ref result 'closure-path))
(generated-files (assoc-ref result 'generated-files))
(references (assoc-ref result 'references))
(base-package-stores (assoc-ref result 'base-package-stores))
(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 . "build")
(os_file . ,os-file)
(system_variable . ,resolved-symbol)
(store_dir . ,store-dir)
(closure_path . ,closure-path)
(freebsd_base_name . ,(freebsd-base-name base))
(freebsd_base_version_label . ,(freebsd-base-version-label base))
(freebsd_base_release . ,(freebsd-base-release base))
(freebsd_base_branch . ,(freebsd-base-branch base))
(freebsd_base_source_root . ,(freebsd-base-source-root base))
(freebsd_base_target . ,(freebsd-base-target base))
(freebsd_base_target_arch . ,(freebsd-base-target-arch base))
(freebsd_base_kernconf . ,(freebsd-base-kernconf base))
(freebsd_base_file . ,(assoc-ref result 'freebsd-base-file))
(freebsd_source_name . ,(freebsd-source-name source))
(freebsd_source_kind . ,(freebsd-source-kind source))
(freebsd_source_url . ,(or (freebsd-source-url source) ""))
(freebsd_source_path . ,(or (freebsd-source-path source) ""))
(freebsd_source_ref . ,(or (freebsd-source-ref source) ""))
(freebsd_source_commit . ,(or (freebsd-source-commit source) ""))
(freebsd_source_sha256 . ,(or (freebsd-source-sha256 source) ""))
(freebsd_source_file . ,(assoc-ref result 'freebsd-source-file))
(ready_marker . ,(operating-system-ready-marker os))
(kernel_store . ,(assoc-ref result 'kernel-store))
(bootloader_store . ,(assoc-ref result 'bootloader-store))
(guile_store . ,(assoc-ref result 'guile-store))
(guile_extra_store . ,(assoc-ref result 'guile-extra-store))
(shepherd_store . ,(assoc-ref result 'shepherd-store))
(base_package_store_count . ,(length base-package-stores))
(base_package_stores . ,(string-join base-package-stores ","))
(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))
(generated_file_count . ,(length generated-files))
(reference_count . ,(length references))))))
(define (emit-system-image-metadata os-file resolved-symbol store-dir os result)
(let* ((image-spec (assoc-ref result 'image-spec))
(store-items (assoc-ref result 'store-items))
(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 . "image")
(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))
(disk_capacity . ,(assoc-ref image-spec 'disk-capacity))
(root_size . ,(assoc-ref image-spec 'root-size))
(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))
(closure_path . ,(assoc-ref result 'closure-path))
(host_base_store_count . ,(length host-base-stores))
(host_base_stores . ,(string-join host-base-stores ","))
(native_base_store_count . ,(length native-base-stores))
(native_base_stores . ,(string-join native-base-stores ","))
(fruix_runtime_store_count . ,(length fruix-runtime-stores))
(fruix_runtime_stores . ,(string-join fruix-runtime-stores ","))
(host_base_provenance_file . ,(assoc-ref result 'host-base-provenance-file))
(store_layout_file . ,(assoc-ref result 'store-layout-file))
(host_freebsd_version . ,(assoc-ref host-provenance 'freebsd-version-kru))
(host_uname . ,(assoc-ref host-provenance 'uname))
(usr_src_git_revision . ,(assoc-ref host-provenance 'usr-src-git-revision))
(usr_src_git_branch . ,(assoc-ref host-provenance 'usr-src-git-branch))
(usr_src_newvers_sha256 . ,(assoc-ref host-provenance 'usr-src-newvers-sha256))
(store_item_count . ,(length store-items))))))
(define (main argv) (define (main argv)
(let* ((parsed (parse-arguments argv)) (let* ((parsed (parse-arguments argv))
(command (assoc-ref parsed 'command))
(action (assoc-ref parsed 'action)) (action (assoc-ref parsed 'action))
(positional (assoc-ref parsed 'positional)) (store-dir (assoc-ref parsed 'store-dir)))
(store-dir (assoc-ref parsed 'store-dir))
(disk-capacity (assoc-ref parsed 'disk-capacity))
(root-size (assoc-ref parsed 'root-size))
(rootfs-opt (assoc-ref parsed 'rootfs))
(system-name (assoc-ref parsed 'system-name))
(requested-symbol (and system-name (string->symbol system-name))))
(cond (cond
((member action '("build" "image" "rootfs")) #t) ((string=? command "system")
(else (error "unknown system action" action))) (let* ((positional (assoc-ref parsed 'positional))
(let* ((os-file (match positional (disk-capacity (assoc-ref parsed 'disk-capacity))
((file . _) file) (root-size (assoc-ref parsed 'root-size))
(() (error "missing operating-system file argument")))) (rootfs-opt (assoc-ref parsed 'rootfs))
(rootfs (or rootfs-opt (system-name (assoc-ref parsed 'system-name))
(and (string=? action "rootfs") (requested-symbol (and system-name (string->symbol system-name))))
(match positional (unless (member action '("build" "image" "rootfs"))
((_ dir) dir) (error "unknown system action" action))
((_ _ dir . _) dir) (let* ((os-file (match positional
(_ #f)))))) ((file . _) file)
(call-with-values (() (error "missing operating-system file argument"))))
(lambda () (rootfs (or rootfs-opt
(load-operating-system-from-file os-file requested-symbol)) (and (string=? action "rootfs")
(lambda (os resolved-symbol) (match positional
(let* ((guile-prefix (or (getenv "GUILE_PREFIX") "/tmp/guile-freebsd-validate-install")) ((_ dir) dir)
(guile-extra-prefix (or (getenv "GUILE_EXTRA_PREFIX") "/tmp/guile-gnutls-freebsd-validate-install")) ((_ _ dir . _) dir)
(shepherd-prefix (or (getenv "SHEPHERD_PREFIX") "/tmp/shepherd-freebsd-validate-install"))) (_ #f))))))
(cond (call-with-values
((string=? action "build") (lambda ()
(let* ((result (materialize-operating-system os (load-operating-system-from-file os-file requested-symbol))
#:store-dir store-dir (lambda (os resolved-symbol)
#:guile-prefix guile-prefix (let* ((guile-prefix (or (getenv "GUILE_PREFIX") "/tmp/guile-freebsd-validate-install"))
#:guile-extra-prefix guile-extra-prefix (guile-extra-prefix (or (getenv "GUILE_EXTRA_PREFIX") "/tmp/guile-gnutls-freebsd-validate-install"))
#:shepherd-prefix shepherd-prefix)) (shepherd-prefix (or (getenv "SHEPHERD_PREFIX") "/tmp/shepherd-freebsd-validate-install")))
(closure-path (assoc-ref result 'closure-path)) (cond
(generated-files (assoc-ref result 'generated-files)) ((string=? action "build")
(references (assoc-ref result 'references)) (emit-system-build-metadata
(base-package-stores (assoc-ref result 'base-package-stores)) os-file resolved-symbol store-dir os
(host-base-stores (assoc-ref result 'host-base-stores)) (materialize-operating-system os
(native-base-stores (assoc-ref result 'native-base-stores)) #:store-dir store-dir
(fruix-runtime-stores (assoc-ref result 'fruix-runtime-stores)) #:guile-prefix guile-prefix
(base (operating-system-freebsd-base os)) #:guile-extra-prefix guile-extra-prefix
(source (freebsd-base-source base)) #:shepherd-prefix shepherd-prefix)))
(host-provenance (call-with-input-file (assoc-ref result 'host-base-provenance-file) read))) ((string=? action "rootfs")
(unless rootfs
(error "rootfs action requires ROOTFS-DIR or --rootfs DIR"))
(let ((result (materialize-rootfs os rootfs
#:store-dir store-dir
#:guile-prefix guile-prefix
#:guile-extra-prefix guile-extra-prefix
#:shepherd-prefix shepherd-prefix)))
(emit-metadata
`((action . "rootfs")
(os_file . ,os-file)
(system_variable . ,resolved-symbol)
(store_dir . ,store-dir)
(rootfs . ,(assoc-ref result 'rootfs))
(closure_path . ,(assoc-ref result 'closure-path))
(ready_marker . ,(assoc-ref result 'ready-marker))
(rc_script . ,(assoc-ref result 'rc-script))))))
((string=? action "image")
(emit-system-image-metadata
os-file resolved-symbol store-dir os
(materialize-bhyve-image os
#:store-dir store-dir
#:guile-prefix guile-prefix
#:guile-extra-prefix guile-extra-prefix
#:shepherd-prefix shepherd-prefix
#:root-size (or root-size "256m")
#:disk-capacity disk-capacity))))))))))
((string=? command "source")
(let* ((positional (assoc-ref parsed 'positional))
(cache-dir (assoc-ref parsed 'cache-dir))
(source-name (assoc-ref parsed 'source-name))
(requested-symbol (and source-name (string->symbol source-name))))
(unless (string=? action "materialize")
(error "unknown source action" action))
(let ((source-file (match positional
((file . _) file)
(() (error "missing freebsd-source file argument")))))
(call-with-values
(lambda ()
(load-freebsd-source-from-file source-file requested-symbol))
(lambda (source resolved-symbol)
(let* ((result (materialize-freebsd-source source
#:store-dir store-dir
#:cache-dir cache-dir))
(effective (assoc-ref result 'effective-source)))
(emit-metadata (emit-metadata
`((action . "build") `((action . "materialize")
(os_file . ,os-file) (source_file . ,source-file)
(system_variable . ,resolved-symbol) (source_variable . ,resolved-symbol)
(store_dir . ,store-dir) (store_dir . ,store-dir)
(closure_path . ,closure-path) (cache_dir . ,cache-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_name . ,(freebsd-source-name source))
(freebsd_source_kind . ,(freebsd-source-kind source)) (freebsd_source_kind . ,(freebsd-source-kind source))
(freebsd_source_url . ,(or (freebsd-source-url source) "")) (freebsd_source_url . ,(or (freebsd-source-url source) ""))
@@ -200,105 +424,18 @@ Options:\n\
(freebsd_source_ref . ,(or (freebsd-source-ref source) "")) (freebsd_source_ref . ,(or (freebsd-source-ref source) ""))
(freebsd_source_commit . ,(or (freebsd-source-commit source) "")) (freebsd_source_commit . ,(or (freebsd-source-commit source) ""))
(freebsd_source_sha256 . ,(or (freebsd-source-sha256 source) "")) (freebsd_source_sha256 . ,(or (freebsd-source-sha256 source) ""))
(freebsd_source_file . ,(assoc-ref result 'freebsd-source-file)) (materialized_source_store . ,(assoc-ref result 'source-store-path))
(ready_marker . ,(operating-system-ready-marker os)) (materialized_source_root . ,(assoc-ref result 'source-root))
(kernel_store . ,(assoc-ref result 'kernel-store)) (materialized_source_info_file . ,(assoc-ref result 'source-info-file))
(bootloader_store . ,(assoc-ref result 'bootloader-store)) (materialized_source_tree_sha256 . ,(assoc-ref result 'source-tree-sha256))
(guile_store . ,(assoc-ref result 'guile-store)) (materialized_source_cache_path . ,(or (assoc-ref result 'cache-path) ""))
(guile_extra_store . ,(assoc-ref result 'guile-extra-store)) (materialized_source_kind . ,(assoc-ref effective 'kind))
(shepherd_store . ,(assoc-ref result 'shepherd-store)) (materialized_source_url . ,(or (assoc-ref effective 'url) ""))
(base_package_store_count . ,(length base-package-stores)) (materialized_source_path . ,(or (assoc-ref effective 'path) ""))
(base_package_stores . ,(string-join base-package-stores ",")) (materialized_source_ref . ,(or (assoc-ref effective 'ref) ""))
(host_base_store_count . ,(length host-base-stores)) (materialized_source_commit . ,(or (assoc-ref result 'effective-commit) ""))
(host_base_stores . ,(string-join host-base-stores ",")) (materialized_source_sha256 . ,(or (assoc-ref result 'effective-sha256) ""))))))))))
(native_base_store_count . ,(length native-base-stores)) (else
(native_base_stores . ,(string-join native-base-stores ",")) (usage 1)))))
(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))
(generated_file_count . ,(length generated-files))
(reference_count . ,(length references))))))
((string=? action "rootfs")
(unless rootfs
(error "rootfs action requires ROOTFS-DIR or --rootfs DIR"))
(let ((result (materialize-rootfs os rootfs
#:store-dir store-dir
#:guile-prefix guile-prefix
#:guile-extra-prefix guile-extra-prefix
#:shepherd-prefix shepherd-prefix)))
(emit-metadata
`((action . "rootfs")
(os_file . ,os-file)
(system_variable . ,resolved-symbol)
(store_dir . ,store-dir)
(rootfs . ,(assoc-ref result 'rootfs))
(closure_path . ,(assoc-ref result 'closure-path))
(ready_marker . ,(assoc-ref result 'ready-marker))
(rc_script . ,(assoc-ref result 'rc-script))))))
((string=? action "image")
(let* ((result (materialize-bhyve-image os
#:store-dir store-dir
#:guile-prefix guile-prefix
#:guile-extra-prefix guile-extra-prefix
#:shepherd-prefix shepherd-prefix
#:root-size (or root-size "256m")
#:disk-capacity disk-capacity))
(image-spec (assoc-ref result 'image-spec))
(store-items (assoc-ref result 'store-items))
(host-base-stores (assoc-ref result 'host-base-stores))
(native-base-stores (assoc-ref result 'native-base-stores))
(fruix-runtime-stores (assoc-ref result 'fruix-runtime-stores))
(base (operating-system-freebsd-base os))
(source (freebsd-base-source base))
(host-provenance (call-with-input-file (assoc-ref result 'host-base-provenance-file) read)))
(emit-metadata
`((action . "image")
(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))
(disk_capacity . ,(assoc-ref image-spec 'disk-capacity))
(root_size . ,(assoc-ref image-spec 'root-size))
(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))
(closure_path . ,(assoc-ref result 'closure-path))
(host_base_store_count . ,(length host-base-stores))
(host_base_stores . ,(string-join host-base-stores ","))
(native_base_store_count . ,(length native-base-stores))
(native_base_stores . ,(string-join native-base-stores ","))
(fruix_runtime_store_count . ,(length fruix-runtime-stores))
(fruix_runtime_stores . ,(string-join fruix-runtime-stores ","))
(host_base_provenance_file . ,(assoc-ref result 'host-base-provenance-file))
(store_layout_file . ,(assoc-ref result 'store-layout-file))
(host_freebsd_version . ,(assoc-ref host-provenance 'freebsd-version-kru))
(host_uname . ,(assoc-ref host-provenance 'uname))
(usr_src_git_revision . ,(assoc-ref host-provenance 'usr-src-git-revision))
(usr_src_git_branch . ,(assoc-ref host-provenance 'usr-src-git-branch))
(usr_src_newvers_sha256 . ,(assoc-ref host-provenance 'usr-src-newvers-sha256))
(store_item_count . ,(length store-items)))))))))))))
(main (command-line)) (main (command-line))

7
tests/system/phase16-git-freebsd-source.scm.in Normal file
View File

@@ -0,0 +1,7 @@
(use-modules (fruix packages freebsd))
(define phase16-source
(freebsd-source
#:name "__SOURCE_NAME__"
#:kind 'git
#:ref "__SOURCE_REF__"))

8
tests/system/phase16-txz-freebsd-source.scm.in Normal file
View File

@@ -0,0 +1,8 @@
(use-modules (fruix packages freebsd))
(define phase16-source
(freebsd-source
#:name "__SOURCE_NAME__"
#:kind 'src-txz
#:url "__SOURCE_URL__"
#:sha256 "__SOURCE_SHA256__"))

224
tests/system/run-phase16-source-materialization.sh Executable file
View File

@@ -0,0 +1,224 @@
#!/bin/sh
set -eu
project_root=${PROJECT_ROOT:-$(pwd)}
script_dir=$(CDPATH= cd -- "$(dirname "$0")" && pwd)
fruix_cmd=$project_root/bin/fruix
git_template=${GIT_SOURCE_TEMPLATE:-$script_dir/phase16-git-freebsd-source.scm.in}
txz_template=${TXZ_SOURCE_TEMPLATE:-$script_dir/phase16-txz-freebsd-source.scm.in}
store_dir=${STORE_DIR:-/frx/store}
cache_dir=${CACHE_DIR:-/frx/var/cache/fruix/freebsd-source}
git_source_name=${GIT_SOURCE_NAME:-stable15-git-ref}
git_source_ref=${GIT_SOURCE_REF:-stable/15}
txz_source_name=${TXZ_SOURCE_NAME:-release15-src-txz}
txz_source_url=${TXZ_SOURCE_URL:-https://download.freebsd.org/releases/amd64/15.0-RELEASE/src.txz}
txz_source_sha256=${TXZ_SOURCE_SHA256:-83c3e8157b6d7afcae57167fda75693bf1e5f581ca149a6ecb2d398b71bdfab0}
metadata_target=${METADATA_OUT:-}
[ -x "$fruix_cmd" ] || {
echo "fruix command is not executable: $fruix_cmd" >&2
exit 1
}
[ -f "$git_template" ] || {
echo "missing git source template: $git_template" >&2
exit 1
}
[ -f "$txz_template" ] || {
echo "missing txz source template: $txz_template" >&2
exit 1
}
cleanup=0
if [ -n "${WORKDIR:-}" ]; then
workdir=$WORKDIR
mkdir -p "$workdir"
else
workdir=$(mktemp -d /tmp/fruix-phase16-source-materialization.XXXXXX)
cleanup=1
fi
if [ "${KEEP_WORKDIR:-0}" -eq 1 ]; then
cleanup=0
fi
cleanup_workdir() {
if [ "$cleanup" -eq 1 ]; then
rm -rf "$workdir" 2>/dev/null || sudo rm -rf "$workdir"
fi
}
trap cleanup_workdir EXIT INT TERM
git_source_file=$workdir/git-source.scm
txz_source_file=$workdir/txz-source.scm
git_out_first=$workdir/git-first.txt
git_out_second=$workdir/git-second.txt
txz_out_first=$workdir/txz-first.txt
txz_out_second=$workdir/txz-second.txt
metadata_file=$workdir/phase16-source-materialization-metadata.txt
sed \
-e "s|__SOURCE_NAME__|$git_source_name|g" \
-e "s|__SOURCE_REF__|$git_source_ref|g" \
"$git_template" > "$git_source_file"
sed \
-e "s|__SOURCE_NAME__|$txz_source_name|g" \
-e "s|__SOURCE_URL__|$txz_source_url|g" \
-e "s|__SOURCE_SHA256__|$txz_source_sha256|g" \
"$txz_template" > "$txz_source_file"
action_env() {
sudo env \
HOME="$HOME" \
GUILE_AUTO_COMPILE=0 \
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}" \
"$@"
}
extract_field() {
key=$1
file=$2
sed -n "s/^${key}=//p" "$file" | tail -n 1
}
assert_hex40() {
value=$1
label=$2
printf '%s\n' "$value" | grep -E '^[0-9a-f]{40}$' >/dev/null || {
echo "expected 40-hex $label, got: $value" >&2
exit 1
}
}
assert_hex64() {
value=$1
label=$2
printf '%s\n' "$value" | grep -E '^[0-9a-f]{64}$' >/dev/null || {
echo "expected 64-hex $label, got: $value" >&2
exit 1
}
}
assert_file() {
path=$1
[ -e "$path" ] || {
echo "missing expected path: $path" >&2
exit 1
}
}
action_env "$fruix_cmd" source materialize "$git_source_file" --source phase16-source --store "$store_dir" --cache "$cache_dir" > "$git_out_first"
action_env "$fruix_cmd" source materialize "$git_source_file" --source phase16-source --store "$store_dir" --cache "$cache_dir" > "$git_out_second"
action_env "$fruix_cmd" source materialize "$txz_source_file" --source phase16-source --store "$store_dir" --cache "$cache_dir" > "$txz_out_first"
action_env "$fruix_cmd" source materialize "$txz_source_file" --source phase16-source --store "$store_dir" --cache "$cache_dir" > "$txz_out_second"
git_store_first=$(extract_field materialized_source_store "$git_out_first")
git_store_second=$(extract_field materialized_source_store "$git_out_second")
git_root_first=$(extract_field materialized_source_root "$git_out_first")
git_info_first=$(extract_field materialized_source_info_file "$git_out_first")
git_tree_sha_first=$(extract_field materialized_source_tree_sha256 "$git_out_first")
git_cache_first=$(extract_field materialized_source_cache_path "$git_out_first")
git_kind_first=$(extract_field materialized_source_kind "$git_out_first")
git_url_first=$(extract_field materialized_source_url "$git_out_first")
git_ref_first=$(extract_field materialized_source_ref "$git_out_first")
git_commit_first=$(extract_field materialized_source_commit "$git_out_first")
txz_store_first=$(extract_field materialized_source_store "$txz_out_first")
txz_store_second=$(extract_field materialized_source_store "$txz_out_second")
txz_root_first=$(extract_field materialized_source_root "$txz_out_first")
txz_info_first=$(extract_field materialized_source_info_file "$txz_out_first")
txz_tree_sha_first=$(extract_field materialized_source_tree_sha256 "$txz_out_first")
txz_cache_first=$(extract_field materialized_source_cache_path "$txz_out_first")
txz_kind_first=$(extract_field materialized_source_kind "$txz_out_first")
txz_url_first=$(extract_field materialized_source_url "$txz_out_first")
txz_sha_first=$(extract_field materialized_source_sha256 "$txz_out_first")
[ "$git_store_first" = "$git_store_second" ] || {
echo "git materialization was not stable across two runs" >&2
exit 1
}
[ "$txz_store_first" = "$txz_store_second" ] || {
echo "txz materialization was not stable across two runs" >&2
exit 1
}
[ "$git_kind_first" = git ] || {
echo "unexpected git materialized kind: $git_kind_first" >&2
exit 1
}
[ "$git_url_first" = https://git.FreeBSD.org/src.git ] || {
echo "unexpected git materialized URL: $git_url_first" >&2
exit 1
}
[ "$git_ref_first" = "$git_source_ref" ] || {
echo "unexpected git materialized ref: $git_ref_first" >&2
exit 1
}
assert_hex40 "$git_commit_first" "git materialized commit"
assert_hex64 "$git_tree_sha_first" "git source tree sha256"
assert_file "$git_store_first"
assert_file "$git_root_first"
assert_file "$git_info_first"
assert_file "$git_cache_first"
assert_file "$git_root_first/Makefile"
assert_file "$git_root_first/sys/conf/newvers.sh"
[ "$txz_kind_first" = src-txz ] || {
echo "unexpected txz materialized kind: $txz_kind_first" >&2
exit 1
}
[ "$txz_url_first" = "$txz_source_url" ] || {
echo "unexpected txz materialized URL: $txz_url_first" >&2
exit 1
}
[ "$txz_sha_first" = "$txz_source_sha256" ] || {
echo "unexpected txz materialized sha256: $txz_sha_first" >&2
exit 1
}
assert_hex64 "$txz_tree_sha_first" "txz source tree sha256"
assert_file "$txz_store_first"
assert_file "$txz_root_first"
assert_file "$txz_info_first"
assert_file "$txz_cache_first"
assert_file "$txz_root_first/Makefile"
assert_file "$txz_root_first/sys/conf/newvers.sh"
cat > "$metadata_file" <<EOF
workdir=$workdir
git_source_file=$git_source_file
git_store_path=$git_store_first
git_source_root=$git_root_first
git_source_info_file=$git_info_first
git_source_tree_sha256=$git_tree_sha_first
git_cache_path=$git_cache_first
git_url=$git_url_first
git_ref=$git_ref_first
git_resolved_commit=$git_commit_first
txz_source_file=$txz_source_file
txz_store_path=$txz_store_first
txz_source_root=$txz_root_first
txz_source_info_file=$txz_info_first
txz_source_tree_sha256=$txz_tree_sha_first
txz_cache_path=$txz_cache_first
txz_url=$txz_url_first
txz_sha256=$txz_sha_first
source_materialization=ok
EOF
if [ -n "$metadata_target" ]; then
mkdir -p "$(dirname "$metadata_target")"
cp "$metadata_file" "$metadata_target"
fi
printf 'PASS phase16-source-materialization\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' '--- git materialization ---'
cat "$git_out_first"
printf '%s\n' '--- txz materialization ---'
cat "$txz_out_first"
printf '%s\n' '--- metadata ---'
cat "$metadata_file"