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

native-build: promote results into store objects

Browse Source
This commit is contained in:
Steffen
2026-04-06 01:16:44 +02:00
parent 4614592a25
commit 006ffee615
12 changed files with 863 additions and 26 deletions
Download Patch File Download Diff File Expand all files Collapse all files

57
scripts/fruix.scm
View File

@@ -15,6 +15,7 @@
Commands:\n\
system ACTION ... Build or materialize Fruix system artifacts.\n\
source ACTION ... Fetch or snapshot declarative FreeBSD source inputs.\n\
native-build ACTION ... Promote native build results into Fruix store objects.\n\
\n\
System actions:\n\
build Materialize the Fruix system closure in /frx/store.\n\
@@ -37,6 +38,12 @@ System options:\n\
Source actions:\n\
materialize Materialize a declared FreeBSD source tree in /frx/store.\n\
\n\
Native-build actions:\n\
promote Promote a native build result root into /frx/store.\n\
\n\
Native-build options:\n\
--store DIR Store directory to use (default: /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\
@@ -216,6 +223,28 @@ Common options:\n\
((arg . tail)
(loop tail (cons arg positional) source-name store-dir cache-dir)))))
(define (parse-native-build-arguments action rest)
(let loop ((args rest)
(positional '())
(store-dir "/frx/store"))
(match args
(()
(let ((positional (reverse positional)))
`((command . "native-build")
(action . ,action)
(positional . ,positional)
(store-dir . ,store-dir))))
(("--help")
(usage 0))
(((? (lambda (arg) (string-prefix? "--store=" arg)) arg) . tail)
(loop tail positional (option-value arg "--store=")))
(("--store" value . tail)
(loop tail positional value))
(((? (lambda (arg) (string-prefix? "--" arg)) arg) . _)
(error "unknown option" arg))
((arg . tail)
(loop tail (cons arg positional) store-dir)))))
(define (parse-arguments argv)
(match argv
((_)
@@ -228,10 +257,14 @@ Common options:\n\
(usage 0))
((_ "source" "--help")
(usage 0))
((_ "native-build" "--help")
(usage 0))
((_ "system" action . rest)
(parse-system-arguments action rest))
((_ "source" action . rest)
(parse-source-arguments action rest))
((_ "native-build" action . rest)
(parse-native-build-arguments action rest))
((_ . _)
(usage 1))))
@@ -542,6 +575,20 @@ Common options:\n\
(target_store_item_count . ,(length target-store-items))
(installer_store_item_count . ,(length installer-store-items))))))
(define (emit-native-build-promotion-metadata store-dir result-root result)
(emit-metadata
`((action . "promote")
(result_root . ,result-root)
(store_dir . ,store-dir)
(result_store . ,(assoc-ref result 'result-store))
(result_metadata_file . ,(assoc-ref result 'result-metadata-file))
(artifact_store_count . ,(assoc-ref result 'artifact-store-count))
(artifact_stores . ,(string-join (assoc-ref result 'artifact-stores) ","))
(world_store . ,(assoc-ref result 'world-store))
(kernel_store . ,(assoc-ref result 'kernel-store))
(headers_store . ,(assoc-ref result 'headers-store))
(bootloader_store . ,(assoc-ref result 'bootloader-store)))))
(define (main argv)
(let* ((parsed (parse-arguments argv))
(command (assoc-ref parsed 'command))
@@ -692,6 +739,16 @@ Common options:\n\
(materialized_source_ref . ,(or (assoc-ref effective 'ref) ""))
(materialized_source_commit . ,(or (assoc-ref result 'effective-commit) ""))
(materialized_source_sha256 . ,(or (assoc-ref result 'effective-sha256) ""))))))))))
((string=? command "native-build")
(let ((positional (assoc-ref parsed 'positional)))
(unless (string=? action "promote")
(error "unknown native-build action" action))
(let ((result-root (match positional
((path . _) path)
(() (error "missing native build result root argument")))))
(emit-native-build-promotion-metadata
store-dir result-root
(promote-native-build-result result-root #:store-dir store-dir)))))
(else
(usage 1)))))