1471 lines
82 KiB
Scheme
1471 lines
82 KiB
Scheme
#!/tmp/guile-freebsd-validate-install/bin/guile -s
|
|
!#
|
|
|
|
(use-modules (fruix installer)
|
|
(fruix system freebsd)
|
|
(fruix system freebsd build)
|
|
(fruix system storage)
|
|
(fruix system freebsd utils)
|
|
(fruix packages freebsd)
|
|
(guix build utils)
|
|
(ice-9 format)
|
|
(ice-9 match)
|
|
(ice-9 hash-table)
|
|
(srfi srfi-1)
|
|
(srfi srfi-13)
|
|
(rnrs io ports))
|
|
|
|
(define (usage code)
|
|
(format (if (= code 0) #t (current-error-port))
|
|
"Usage: fruix COMMAND ...\n\
|
|
\n\
|
|
Commands:\n\
|
|
system ACTION ... Build or materialize Fruix system artifacts.\n\
|
|
package ACTION ... Inspect or materialize Fruix packages.\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\
|
|
deploy Build or transfer a Fruix system closure onto a remote Fruix node over SSH.\n\
|
|
image Materialize the Fruix disk image in /frx/store.\n\
|
|
installer Materialize a bootable Fruix installer image in /frx/store.\n\
|
|
installer-iso Materialize a bootable Fruix installer ISO in /frx/store.\n\
|
|
installer-tui Run the experimental Fruix Newt installer prototype.\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', 'installer', or raw-file 'install' targets.\n\
|
|
--root-size SIZE Root filesystem size for 'image', 'installer', 'installer-iso', or 'install' (example: 6g).\n\
|
|
--target PATH Install target for 'install' (raw image file or /dev/... device).\n\
|
|
Direct /dev/... install targets require\n\
|
|
FRUIX_ASSEMBLY_ALLOW_BLOCK_DEVICE_TARGETS=1.\n\
|
|
--install-target-device DEVICE\n\
|
|
Target block device used by the booted 'installer' environment.\n\
|
|
--self-test Use the Newt self-test path for 'installer-tui'.\n\
|
|
--rootfs DIR Rootfs target for 'rootfs'.\n\
|
|
--host HOST Remote host for 'deploy' (or use TARGET as first positional argument).\n\
|
|
--user USER Remote SSH user for 'deploy' (default: root).\n\
|
|
--port PORT Remote SSH port for 'deploy' (default: 22).\n\
|
|
--identity FILE SSH identity file for 'deploy'.\n\
|
|
--reboot Reboot the remote node after 'deploy'.\n\
|
|
\n\
|
|
Package actions:\n\
|
|
list List known Fruix packages.\n\
|
|
search QUERY Search known Fruix packages by name or text.\n\
|
|
show NAME Show metadata for one Fruix package.\n\
|
|
build NAME Materialize one Fruix package in /frx/store.\n\
|
|
installed List packages installed in a Fruix package profile.\n\
|
|
install NAME... Add packages to a Fruix package profile.\n\
|
|
remove NAME... Remove packages from a Fruix package profile.\n\
|
|
\n\
|
|
Package options:\n\
|
|
--store DIR Store directory to use for 'build' or profile updates (default: /frx/store).\n\
|
|
--profile DIR Package profile state directory (default: $HOME/.local/state/fruix/profiles/default).\n\
|
|
\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\
|
|
--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))
|
|
|
|
(define (option-value arg prefix)
|
|
(and (string-prefix? prefix arg)
|
|
(substring arg (string-length prefix))))
|
|
|
|
(define (stringify value)
|
|
(cond ((string? value) value)
|
|
((symbol? value) (symbol->string value))
|
|
((number? value) (number->string value))
|
|
((boolean? value) (if value "true" "false"))
|
|
(else (call-with-output-string (lambda (port) (write value port))))))
|
|
|
|
(define (emit-metadata fields)
|
|
(for-each (lambda (field)
|
|
(format #t "~a=~a~%" (car field) (stringify (cdr field))))
|
|
fields))
|
|
|
|
(define (read-file-string file)
|
|
(call-with-input-file file get-string-all))
|
|
|
|
(define (lookup-bound-value module symbol)
|
|
(let ((var (module-variable module symbol)))
|
|
(and var (variable-ref var))))
|
|
|
|
(define candidate-operating-system-symbols
|
|
'(operating-system
|
|
phase16-operating-system
|
|
phase15-operating-system
|
|
phase10-operating-system
|
|
phase9-operating-system
|
|
phase8-operating-system
|
|
phase7-operating-system
|
|
default-operating-system
|
|
os))
|
|
|
|
(define candidate-freebsd-source-symbols
|
|
'(phase16-source
|
|
declared-source
|
|
source
|
|
src))
|
|
|
|
(define (resolve-operating-system-symbol module requested)
|
|
(or requested
|
|
(find (lambda (symbol)
|
|
(let ((value (lookup-bound-value module symbol)))
|
|
(and value (operating-system? value))))
|
|
candidate-operating-system-symbols)
|
|
(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)
|
|
(unless (file-exists? file)
|
|
(error "operating-system file does not exist" file))
|
|
(primitive-load file)
|
|
(let* ((module (current-module))
|
|
(symbol (resolve-operating-system-symbol module requested-symbol))
|
|
(value (lookup-bound-value module symbol)))
|
|
(unless (and value (operating-system? value))
|
|
(error "resolved variable is not an operating-system" symbol))
|
|
(validate-operating-system value)
|
|
(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)
|
|
(target #f)
|
|
(install-target-device #f)
|
|
(rootfs #f)
|
|
(deploy-host #f)
|
|
(deploy-user "root")
|
|
(deploy-port "22")
|
|
(identity-file #f)
|
|
(reboot? #f)
|
|
(self-test? #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)
|
|
(target . ,target)
|
|
(install-target-device . ,install-target-device)
|
|
(rootfs . ,rootfs)
|
|
(deploy-host . ,deploy-host)
|
|
(deploy-user . ,deploy-user)
|
|
(deploy-port . ,deploy-port)
|
|
(identity-file . ,identity-file)
|
|
(reboot? . ,reboot?)
|
|
(self-test? . ,self-test?))))
|
|
(("--help")
|
|
(usage 0))
|
|
(((? (lambda (arg) (string-prefix? "--system=" arg)) arg) . tail)
|
|
(loop tail positional (option-value arg "--system=") store-dir disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot? self-test?))
|
|
(("--system" value . tail)
|
|
(loop tail positional value store-dir disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot? self-test?))
|
|
(((? (lambda (arg) (string-prefix? "--store=" arg)) arg) . tail)
|
|
(loop tail positional system-name (option-value arg "--store=") disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot? self-test?))
|
|
(("--store" value . tail)
|
|
(loop tail positional system-name value disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot? self-test?))
|
|
(((? (lambda (arg) (string-prefix? "--disk-capacity=" arg)) arg) . tail)
|
|
(loop tail positional system-name store-dir (option-value arg "--disk-capacity=") root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot? self-test?))
|
|
(("--disk-capacity" value . tail)
|
|
(loop tail positional system-name store-dir value root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot? self-test?))
|
|
(((? (lambda (arg) (string-prefix? "--root-size=" arg)) arg) . tail)
|
|
(loop tail positional system-name store-dir disk-capacity (option-value arg "--root-size=") target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot? self-test?))
|
|
(("--root-size" value . tail)
|
|
(loop tail positional system-name store-dir disk-capacity value target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot? self-test?))
|
|
(((? (lambda (arg) (string-prefix? "--target=" arg)) arg) . tail)
|
|
(loop tail positional system-name store-dir disk-capacity root-size (option-value arg "--target=") install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot? self-test?))
|
|
(("--target" value . tail)
|
|
(loop tail positional system-name store-dir disk-capacity root-size value install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot? self-test?))
|
|
(((? (lambda (arg) (string-prefix? "--install-target-device=" arg)) arg) . tail)
|
|
(loop tail positional system-name store-dir disk-capacity root-size target
|
|
(option-value arg "--install-target-device=") rootfs deploy-host deploy-user deploy-port identity-file reboot? self-test?))
|
|
(("--install-target-device" value . tail)
|
|
(loop tail positional system-name store-dir disk-capacity root-size target value rootfs deploy-host deploy-user deploy-port identity-file reboot? self-test?))
|
|
(((? (lambda (arg) (string-prefix? "--rootfs=" arg)) arg) . tail)
|
|
(loop tail positional system-name store-dir disk-capacity root-size target install-target-device
|
|
(option-value arg "--rootfs=") deploy-host deploy-user deploy-port identity-file reboot? self-test?))
|
|
(("--rootfs" value . tail)
|
|
(loop tail positional system-name store-dir disk-capacity root-size target install-target-device value deploy-host deploy-user deploy-port identity-file reboot? self-test?))
|
|
(((? (lambda (arg) (string-prefix? "--host=" arg)) arg) . tail)
|
|
(loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs
|
|
(option-value arg "--host=") deploy-user deploy-port identity-file reboot? self-test?))
|
|
(("--host" value . tail)
|
|
(loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs value deploy-user deploy-port identity-file reboot? self-test?))
|
|
(((? (lambda (arg) (string-prefix? "--user=" arg)) arg) . tail)
|
|
(loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs
|
|
deploy-host (option-value arg "--user=") deploy-port identity-file reboot? self-test?))
|
|
(("--user" value . tail)
|
|
(loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs deploy-host value deploy-port identity-file reboot? self-test?))
|
|
(((? (lambda (arg) (string-prefix? "--port=" arg)) arg) . tail)
|
|
(loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs
|
|
deploy-host deploy-user (option-value arg "--port=") identity-file reboot? self-test?))
|
|
(("--port" value . tail)
|
|
(loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs deploy-host deploy-user value identity-file reboot? self-test?))
|
|
(((? (lambda (arg) (string-prefix? "--identity=" arg)) arg) . tail)
|
|
(loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs
|
|
deploy-host deploy-user deploy-port (option-value arg "--identity=") reboot? self-test?))
|
|
(("--identity" value . tail)
|
|
(loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port value reboot? self-test?))
|
|
(("--reboot" . tail)
|
|
(loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file #t self-test?))
|
|
(("--self-test" . tail)
|
|
(loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot? #t))
|
|
(((? (lambda (arg) (string-prefix? "--" arg)) arg) . _)
|
|
(error "unknown option" arg))
|
|
((arg . tail)
|
|
(loop tail (cons arg positional) system-name store-dir disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot? self-test?)))))
|
|
|
|
(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-package-arguments action rest)
|
|
(let loop ((args rest)
|
|
(positional '())
|
|
(store-dir "/frx/store")
|
|
(profile-dir #f))
|
|
(match args
|
|
(()
|
|
(let ((positional (reverse positional)))
|
|
`((command . "package")
|
|
(action . ,action)
|
|
(positional . ,positional)
|
|
(store-dir . ,store-dir)
|
|
(profile-dir . ,profile-dir))))
|
|
(("--help")
|
|
(usage 0))
|
|
(((? (lambda (arg) (string-prefix? "--store=" arg)) arg) . tail)
|
|
(loop tail positional (option-value arg "--store=") profile-dir))
|
|
(("--store" value . tail)
|
|
(loop tail positional value profile-dir))
|
|
(((? (lambda (arg) (string-prefix? "--profile=" arg)) arg) . tail)
|
|
(loop tail positional store-dir (option-value arg "--profile=")))
|
|
(("--profile" value . tail)
|
|
(loop tail positional store-dir value))
|
|
(((? (lambda (arg) (string-prefix? "--" arg)) arg) . _)
|
|
(error "unknown option" arg))
|
|
((arg . tail)
|
|
(loop tail (cons arg positional) store-dir profile-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
|
|
((_)
|
|
(usage 1))
|
|
((_ "--help")
|
|
(usage 0))
|
|
((_ "help")
|
|
(usage 0))
|
|
((_ "system" "--help")
|
|
(usage 0))
|
|
((_ "package" "--help")
|
|
(usage 0))
|
|
((_ "source" "--help")
|
|
(usage 0))
|
|
((_ "native-build" "--help")
|
|
(usage 0))
|
|
((_ "system" action . rest)
|
|
(parse-system-arguments action rest))
|
|
((_ "package" action . rest)
|
|
(parse-package-arguments action rest))
|
|
((_ "source" action . rest)
|
|
(parse-source-arguments action rest))
|
|
((_ "native-build" action . rest)
|
|
(parse-native-build-arguments action rest))
|
|
((_ . _)
|
|
(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))
|
|
(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) ","))
|
|
(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-install-metadata os-file resolved-symbol store-dir os result)
|
|
(let* ((install-spec (assoc-ref result 'install-spec))
|
|
(store-items (assoc-ref result 'store-items))
|
|
(host-base-stores (assoc-ref result 'host-base-stores))
|
|
(native-base-stores (assoc-ref result 'native-base-stores))
|
|
(fruix-runtime-stores (assoc-ref result 'fruix-runtime-stores))
|
|
(base (operating-system-freebsd-base os))
|
|
(source (freebsd-base-source base))
|
|
(host-provenance (call-with-input-file (assoc-ref result 'host-base-provenance-file) read)))
|
|
(emit-metadata
|
|
`((action . "install")
|
|
(os_file . ,os-file)
|
|
(system_variable . ,resolved-symbol)
|
|
(store_dir . ,store-dir)
|
|
(target . ,(assoc-ref result 'target))
|
|
(target_kind . ,(assoc-ref result 'target-kind))
|
|
(target_device . ,(assoc-ref result 'target-device))
|
|
(esp_device . ,(assoc-ref result 'esp-device))
|
|
(root_device . ,(assoc-ref result 'root-device))
|
|
(install_metadata_path . ,(assoc-ref result 'install-metadata-path))
|
|
(assembly_privileged_policy_path . ,(assoc-ref result 'assembly-privileged-policy-path))
|
|
(raw_target_attach_metadata_path . ,(or (assoc-ref result 'raw-target-attach-metadata-path) ""))
|
|
(rootfs_populate_metadata_path . ,(assoc-ref result 'rootfs-populate-metadata-path))
|
|
(storage_apply_metadata_path . ,(assoc-ref result 'storage-apply-metadata-path))
|
|
(rootfs_copy_metadata_path . ,(assoc-ref result 'rootfs-copy-metadata-path))
|
|
(store_copy_metadata_path . ,(assoc-ref result 'store-copy-metadata-path))
|
|
(freebsd_base_name . ,(freebsd-base-name base))
|
|
(freebsd_base_version_label . ,(freebsd-base-version-label base))
|
|
(freebsd_base_release . ,(freebsd-base-release base))
|
|
(freebsd_base_branch . ,(freebsd-base-branch base))
|
|
(freebsd_base_source_root . ,(freebsd-base-source-root base))
|
|
(freebsd_base_target . ,(freebsd-base-target base))
|
|
(freebsd_base_target_arch . ,(freebsd-base-target-arch base))
|
|
(freebsd_base_kernconf . ,(freebsd-base-kernconf base))
|
|
(freebsd_base_file . ,(assoc-ref result 'freebsd-base-file))
|
|
(freebsd_source_name . ,(freebsd-source-name source))
|
|
(freebsd_source_kind . ,(freebsd-source-kind source))
|
|
(freebsd_source_url . ,(or (freebsd-source-url source) ""))
|
|
(freebsd_source_path . ,(or (freebsd-source-path source) ""))
|
|
(freebsd_source_ref . ,(or (freebsd-source-ref source) ""))
|
|
(freebsd_source_commit . ,(or (freebsd-source-commit source) ""))
|
|
(freebsd_source_sha256 . ,(or (freebsd-source-sha256 source) ""))
|
|
(freebsd_source_file . ,(assoc-ref result 'freebsd-source-file))
|
|
(freebsd_source_materializations_file . ,(assoc-ref result 'freebsd-source-materializations-file))
|
|
(materialized_source_store_count . ,(length (assoc-ref result 'materialized-source-stores)))
|
|
(materialized_source_stores . ,(string-join (assoc-ref result 'materialized-source-stores) ","))
|
|
(disk_capacity . ,(assoc-ref install-spec 'disk-capacity))
|
|
(root_size . ,(assoc-ref install-spec 'root-size))
|
|
(efi_size . ,(assoc-ref install-spec 'efi-size))
|
|
(closure_path . ,(assoc-ref result 'closure-path))
|
|
(host_base_store_count . ,(length host-base-stores))
|
|
(host_base_stores . ,(string-join host-base-stores ","))
|
|
(native_base_store_count . ,(length native-base-stores))
|
|
(native_base_stores . ,(string-join native-base-stores ","))
|
|
(fruix_runtime_store_count . ,(length fruix-runtime-stores))
|
|
(fruix_runtime_stores . ,(string-join fruix-runtime-stores ","))
|
|
(host_base_provenance_file . ,(assoc-ref result 'host-base-provenance-file))
|
|
(store_layout_file . ,(assoc-ref result 'store-layout-file))
|
|
(host_freebsd_version . ,(assoc-ref host-provenance 'freebsd-version-kru))
|
|
(host_uname . ,(assoc-ref host-provenance 'uname))
|
|
(usr_src_git_revision . ,(assoc-ref host-provenance 'usr-src-git-revision))
|
|
(usr_src_git_branch . ,(assoc-ref host-provenance 'usr-src-git-branch))
|
|
(usr_src_newvers_sha256 . ,(assoc-ref host-provenance 'usr-src-newvers-sha256))
|
|
(store_item_count . ,(length store-items))))))
|
|
|
|
(define (emit-system-image-metadata os-file resolved-symbol store-dir os result)
|
|
(let* ((image-spec (assoc-ref result 'image-spec))
|
|
(store-items (assoc-ref result 'store-items))
|
|
(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))
|
|
(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))
|
|
(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))
|
|
(assembly_privileged_policy_file . ,(assoc-ref result 'assembly-privileged-policy-file))
|
|
(rootfs_populate_metadata_file . ,(assoc-ref result 'rootfs-populate-metadata-file))
|
|
(image_resize_metadata_file . ,(assoc-ref result 'image-resize-metadata-file))
|
|
(image_rootfs_copy_metadata_file . ,(assoc-ref result 'image-rootfs-copy-metadata-file))
|
|
(store_copy_metadata_file . ,(assoc-ref result 'store-copy-metadata-file))
|
|
(closure_path . ,(assoc-ref result 'closure-path))
|
|
(host_base_store_count . ,(length host-base-stores))
|
|
(host_base_stores . ,(string-join host-base-stores ","))
|
|
(native_base_store_count . ,(length native-base-stores))
|
|
(native_base_stores . ,(string-join native-base-stores ","))
|
|
(fruix_runtime_store_count . ,(length fruix-runtime-stores))
|
|
(fruix_runtime_stores . ,(string-join fruix-runtime-stores ","))
|
|
(host_base_provenance_file . ,(assoc-ref result 'host-base-provenance-file))
|
|
(store_layout_file . ,(assoc-ref result 'store-layout-file))
|
|
(host_freebsd_version . ,(assoc-ref host-provenance 'freebsd-version-kru))
|
|
(host_uname . ,(assoc-ref host-provenance 'uname))
|
|
(usr_src_git_revision . ,(assoc-ref host-provenance 'usr-src-git-revision))
|
|
(usr_src_git_branch . ,(assoc-ref host-provenance 'usr-src-git-branch))
|
|
(usr_src_newvers_sha256 . ,(assoc-ref host-provenance 'usr-src-newvers-sha256))
|
|
(store_item_count . ,(length store-items))))))
|
|
|
|
(define (emit-system-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))
|
|
(assembly_privileged_policy_file . ,(assoc-ref result 'assembly-privileged-policy-file))
|
|
(installer_rootfs_populate_metadata_file . ,(assoc-ref result 'installer-rootfs-populate-metadata-file))
|
|
(target_rootfs_populate_metadata_file . ,(assoc-ref result 'target-rootfs-populate-metadata-file))
|
|
(image_resize_metadata_file . ,(assoc-ref result 'image-resize-metadata-file))
|
|
(installer_rootfs_copy_metadata_file . ,(assoc-ref result 'installer-rootfs-copy-metadata-file))
|
|
(target_rootfs_copy_metadata_file . ,(assoc-ref result 'target-rootfs-copy-metadata-file))
|
|
(store_copy_metadata_file . ,(assoc-ref result 'store-copy-metadata-file))
|
|
(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 (emit-system-installer-iso-metadata os-file resolved-symbol store-dir os result)
|
|
(let* ((installer-iso-spec (assoc-ref result 'installer-iso-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-iso")
|
|
(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) ","))
|
|
(installer_host_name . ,(assoc-ref installer-iso-spec 'installer-host-name))
|
|
(install_target_device . ,(assoc-ref result 'install-target-device))
|
|
(iso_volume_label . ,(assoc-ref installer-iso-spec 'iso-volume-label))
|
|
(root_size . ,(assoc-ref installer-iso-spec 'root-size))
|
|
(installer_state_path . ,(assoc-ref result 'installer-state-path))
|
|
(installer_log_path . ,(assoc-ref result 'installer-log-path))
|
|
(iso_store_path . ,(assoc-ref result 'iso-store-path))
|
|
(iso_image . ,(assoc-ref result 'iso-image))
|
|
(boot_efi_image . ,(assoc-ref result 'boot-efi-image))
|
|
(root_image . ,(assoc-ref result 'root-image))
|
|
(assembly_privileged_policy_file . ,(assoc-ref result 'assembly-privileged-policy-file))
|
|
(installer_rootfs_populate_metadata_file . ,(assoc-ref result 'installer-rootfs-populate-metadata-file))
|
|
(target_rootfs_populate_metadata_file . ,(assoc-ref result 'target-rootfs-populate-metadata-file))
|
|
(installer_rootfs_copy_metadata_file . ,(assoc-ref result 'installer-rootfs-copy-metadata-file))
|
|
(target_rootfs_copy_metadata_file . ,(assoc-ref result 'target-rootfs-copy-metadata-file))
|
|
(store_copy_metadata_file . ,(assoc-ref result 'store-copy-metadata-file))
|
|
(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 (emit-installer-tui-metadata os-file resolved-symbol store-dir state result)
|
|
(let* ((state-spec (or (assoc-ref result 'state)
|
|
(installer-state-spec state)))
|
|
(state-value (lambda (key fallback)
|
|
(let ((entry (assoc key state-spec)))
|
|
(if entry (cdr entry) fallback)))))
|
|
(emit-metadata
|
|
`((action . "installer-tui")
|
|
(os_file . ,os-file)
|
|
(system_variable . ,resolved-symbol)
|
|
(store_dir . ,store-dir)
|
|
(newt_mode . ,(assoc-ref result 'mode))
|
|
(newt_available . ,(assoc-ref result 'available?))
|
|
(newt_result . ,(assoc-ref result 'result))
|
|
(newt_error . ,(or (assoc-ref result 'error) #f))
|
|
(missing_bindings . ,(assoc-ref result 'missing-bindings))
|
|
(step_count . ,(assoc-ref result 'step-count))
|
|
(step_ids . ,(assoc-ref result 'step-ids))
|
|
(selected_step . ,(state-value 'selected-step (installer-state-selected-step state)))
|
|
(host_name . ,(state-value 'host-name (installer-state-host-name state)))
|
|
(target_device . ,(state-value 'target-device (installer-state-target-device state)))
|
|
(root_size . ,(state-value 'root-size (installer-state-root-size state)))
|
|
(disk_capacity . ,(state-value 'disk-capacity (installer-state-disk-capacity state)))
|
|
(network_mode . ,(state-value 'network-mode (installer-state-network-mode state)))
|
|
(storage_layout . ,(state-value 'storage-layout
|
|
(and (installer-state-storage-layout state)
|
|
(storage-layout-spec (installer-state-storage-layout state)))))
|
|
(effective_storage_layout . ,(state-value 'effective-storage-layout
|
|
(and (installer-state-effective-storage-layout state)
|
|
(storage-layout-spec (installer-state-effective-storage-layout state)))))))))
|
|
|
|
(define (emit-native-build-promotion-metadata store-dir result-root result)
|
|
(emit-metadata
|
|
`((action . "promote")
|
|
(result_root . ,result-root)
|
|
(store_dir . ,store-dir)
|
|
(executor_kind . ,(assoc-ref result 'executor-kind))
|
|
(executor_name . ,(assoc-ref result 'executor-name))
|
|
(executor_version . ,(assoc-ref result 'executor-version))
|
|
(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 (package-summary-line package)
|
|
(string-append (freebsd-package-name package)
|
|
"\t"
|
|
(freebsd-package-version package)
|
|
"\t"
|
|
(symbol->string (freebsd-package-build-system package))
|
|
"\t"
|
|
(freebsd-package-synopsis package)))
|
|
|
|
(define (emit-package-show-metadata package)
|
|
(emit-metadata
|
|
`((action . "package-show")
|
|
(package_name . ,(freebsd-package-name package))
|
|
(package_version . ,(freebsd-package-version package))
|
|
(build_system . ,(freebsd-package-build-system package))
|
|
(input_count . ,(length (freebsd-package-inputs package)))
|
|
(inputs . ,(string-join (map freebsd-package-name
|
|
(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_target_count . ,(length (freebsd-package-install-plan package)))
|
|
(install_targets
|
|
. ,(string-join (map (lambda (entry)
|
|
(match entry
|
|
((_ _ target) target)))
|
|
(freebsd-package-install-plan package))
|
|
",")))))
|
|
|
|
(define (emit-package-build-metadata store-dir package store-path)
|
|
(emit-metadata
|
|
`((action . "package-build")
|
|
(store_dir . ,store-dir)
|
|
(package_name . ,(freebsd-package-name package))
|
|
(package_version . ,(freebsd-package-version package))
|
|
(build_system . ,(freebsd-package-build-system package))
|
|
(store_path . ,store-path)
|
|
(references_file . ,(string-append store-path "/.references"))
|
|
(package_metadata_file . ,(string-append store-path "/.fruix-package")))))
|
|
|
|
(define profile-manifest-version "1")
|
|
|
|
(define (default-package-profile-dir)
|
|
(let ((home (or (getenv "HOME") ".")))
|
|
(string-append home "/.local/state/fruix/profiles/default")))
|
|
|
|
(define (package-profile-manifest-path profile-dir)
|
|
(string-append profile-dir "/manifest.scm"))
|
|
|
|
(define (package-profile-generation-file profile-dir)
|
|
(string-append profile-dir "/current-generation"))
|
|
|
|
(define (package-profile-current-link profile-dir)
|
|
(string-append profile-dir "/current"))
|
|
|
|
(define (package-profile-generate-link profile-dir generation)
|
|
(string-append profile-dir "/generations/" (number->string generation)))
|
|
|
|
(define (path-directory path)
|
|
(let ((index (string-index-right path #\/)))
|
|
(if index
|
|
(substring path 0 index)
|
|
".")))
|
|
|
|
(define (path-present? path)
|
|
(or (file-exists? path)
|
|
(false-if-exception (readlink path))))
|
|
|
|
(define (symlink-force target link-name)
|
|
(mkdir-p (path-directory link-name))
|
|
(delete-path-if-exists link-name)
|
|
(symlink target link-name))
|
|
|
|
(define (package-profile-activate-script)
|
|
(string-append
|
|
"#!/bin/sh\n"
|
|
"set -eu\n"
|
|
"profile=$(CDPATH= cd -- \"$(dirname \"$0\")\" && pwd)\n"
|
|
"cat <<EOF\n"
|
|
"export FRUIX_PROFILE=\"$profile\"\n"
|
|
"export PATH=\"$profile/bin:$profile/sbin:$profile/usr/bin:$profile/usr/sbin${PATH:+:$PATH}\"\n"
|
|
"export LD_LIBRARY_PATH=\"$profile/lib:$profile/usr/lib${LD_LIBRARY_PATH:+:$LD_LIBRARY_PATH}\"\n"
|
|
"export MANPATH=\"$profile/share/man:$profile/usr/share/man${MANPATH:+:$MANPATH}\"\n"
|
|
"export NODE_PATH=\"$profile/lib/node_modules${NODE_PATH:+:$NODE_PATH}\"\n"
|
|
"export VIMRUNTIME=\"$profile/share/nvim/runtime\"\n"
|
|
"export LUA_CPATH=\"$profile/lib/lua/5.1/?.so${LUA_CPATH:+;$LUA_CPATH};;\"\n"
|
|
"EOF\n"))
|
|
|
|
(define (read-package-profile-manifest profile-dir)
|
|
(let ((path (package-profile-manifest-path profile-dir)))
|
|
(if (file-exists? path)
|
|
(call-with-input-file path read)
|
|
'((version . "1")
|
|
(packages . ())))))
|
|
|
|
(define (package-profile-package-names profile-dir)
|
|
(let ((manifest (read-package-profile-manifest profile-dir)))
|
|
(or (assoc-ref manifest 'packages) '())))
|
|
|
|
(define (normalize-package-names names)
|
|
(sort (delete-duplicates names string=?) string<?))
|
|
|
|
(define (resolve-package-list names)
|
|
(map (lambda (name)
|
|
(or (find-freebsd-package name)
|
|
(error "unknown package" name)))
|
|
names))
|
|
|
|
(define (materialize-package-profile package-names store-dir)
|
|
(let* ((normalized (normalize-package-names package-names))
|
|
(packages (resolve-package-list normalized))
|
|
(cache (make-hash-table))
|
|
(source-cache (make-hash-table))
|
|
(package-stores (map (lambda (package)
|
|
(materialize-freebsd-package package store-dir cache source-cache))
|
|
packages))
|
|
(payload (object->string `((profile-version . ,profile-manifest-version)
|
|
(packages . ,normalized)
|
|
(package-stores . ,package-stores))))
|
|
(profile-store (make-store-path store-dir "fruix-package-profile" payload
|
|
#:kind 'profile))
|
|
(profile-jail-metadata-file (string-append profile-store "/.fruix-build-jail.scm")))
|
|
(unless (file-exists? profile-store)
|
|
(mkdir-p profile-store)
|
|
(materialize-package-profile-tree package-stores profile-store
|
|
#:metadata-file profile-jail-metadata-file)
|
|
(write-file (string-append profile-store "/.references")
|
|
(string-join package-stores "\n"))
|
|
(write-file (string-append profile-store "/.fruix-profile.scm")
|
|
(object->string `((version . ,profile-manifest-version)
|
|
(packages . ,normalized)
|
|
(package-stores . ,package-stores))))
|
|
(write-file (string-append profile-store "/activate")
|
|
(package-profile-activate-script))
|
|
(chmod (string-append profile-store "/activate") #o555))
|
|
`((profile-store . ,profile-store)
|
|
(profile-jail-metadata-file . ,profile-jail-metadata-file)
|
|
(package-stores . ,package-stores)
|
|
(packages . ,normalized))))
|
|
|
|
(define (next-package-profile-generation profile-dir)
|
|
(let ((path (package-profile-generation-file profile-dir)))
|
|
(if (file-exists? path)
|
|
(+ 1 (string->number (call-with-input-file path get-string-all)))
|
|
1)))
|
|
|
|
(define (update-package-profile profile-dir store-dir package-names)
|
|
(let* ((materialized (materialize-package-profile package-names store-dir))
|
|
(normalized (assoc-ref materialized 'packages))
|
|
(profile-store (assoc-ref materialized 'profile-store))
|
|
(generation (next-package-profile-generation profile-dir))
|
|
(generation-link (package-profile-generate-link profile-dir generation))
|
|
(current-link (package-profile-current-link profile-dir))
|
|
(activate-link (string-append profile-dir "/activate"))
|
|
(manifest-path (package-profile-manifest-path profile-dir)))
|
|
(mkdir-p (string-append profile-dir "/generations"))
|
|
(symlink-force profile-store generation-link)
|
|
(symlink-force (string-append "generations/" (number->string generation))
|
|
current-link)
|
|
(symlink-force "current/activate" activate-link)
|
|
(write-file (package-profile-generation-file profile-dir)
|
|
(number->string generation))
|
|
(write-file manifest-path
|
|
(object->string `((version . ,profile-manifest-version)
|
|
(generation . ,generation)
|
|
(profile-store . ,profile-store)
|
|
(packages . ,normalized))))
|
|
`((profile-dir . ,profile-dir)
|
|
(generation . ,generation)
|
|
(profile-store . ,profile-store)
|
|
(profile-jail-metadata-file . ,(match (assoc 'profile-jail-metadata-file materialized)
|
|
((_ . value) value)
|
|
(#f #f)))
|
|
(current-link . ,current-link)
|
|
(activate-link . ,activate-link)
|
|
(manifest-path . ,manifest-path)
|
|
(packages . ,normalized)
|
|
(package-count . ,(length normalized)))))
|
|
|
|
(define (emit-package-profile-metadata action store-dir result)
|
|
(emit-metadata
|
|
`((action . ,action)
|
|
(store_dir . ,store-dir)
|
|
(profile_dir . ,(assoc-ref result 'profile-dir))
|
|
(generation . ,(assoc-ref result 'generation))
|
|
(profile_store . ,(assoc-ref result 'profile-store))
|
|
(profile_jail_metadata_file . ,(match (assoc 'profile-jail-metadata-file result)
|
|
((_ . value) value)
|
|
(#f #f)))
|
|
(current_link . ,(assoc-ref result 'current-link))
|
|
(activate_link . ,(assoc-ref result 'activate-link))
|
|
(manifest_path . ,(assoc-ref result 'manifest-path))
|
|
(package_count . ,(assoc-ref result 'package-count))
|
|
(packages . ,(string-join (assoc-ref result 'packages) ",")))))
|
|
|
|
(define (shell-quote text)
|
|
(string-append "'" (string-replace-all text "'" "'\"'\"'") "'"))
|
|
|
|
(define (command-success? program . args)
|
|
(zero? (apply system* program args)))
|
|
|
|
(define* (ssh-base-args host #:key (user "root") (port "22") (identity-file #f))
|
|
(append (list "-o" "BatchMode=yes"
|
|
"-o" "StrictHostKeyChecking=no"
|
|
"-o" "UserKnownHostsFile=/dev/null"
|
|
"-o" "ConnectTimeout=5"
|
|
"-p" port)
|
|
(if identity-file
|
|
(list "-i" identity-file)
|
|
'())
|
|
(list (string-append user "@" host))))
|
|
|
|
(define* (ssh-command-prefix host #:key (user "root") (port "22") (identity-file #f))
|
|
(string-join
|
|
(map shell-quote
|
|
(append (list "ssh")
|
|
(ssh-base-args host #:user user #:port port #:identity-file identity-file)))
|
|
" "))
|
|
|
|
(define* (ssh-shell-output host command #:key (user "root") (port "22") (identity-file #f))
|
|
(trim-trailing-newlines
|
|
(apply command-output
|
|
"ssh"
|
|
(append (ssh-base-args host #:user user #:port port #:identity-file identity-file)
|
|
(list (string-append "set -eu; " command))))))
|
|
|
|
(define* (ssh-shell-success? host command #:key (user "root") (port "22") (identity-file #f))
|
|
(apply command-success?
|
|
"ssh"
|
|
(append (ssh-base-args host #:user user #:port port #:identity-file identity-file)
|
|
(list (string-append "set -eu; " command)))))
|
|
|
|
(define (metadata-value text key)
|
|
(let ((prefix (string-append key "=")))
|
|
(let loop ((lines (string-split text #\newline)))
|
|
(match lines
|
|
(() #f)
|
|
((line . rest)
|
|
(if (string-prefix? prefix line)
|
|
(substring line (string-length prefix))
|
|
(loop rest)))))))
|
|
|
|
(define (system-closure-path? path)
|
|
(and (file-exists? path)
|
|
(file-exists? (string-append path "/activate"))
|
|
(file-exists? (string-append path "/shepherd/init.scm"))
|
|
(file-exists? (string-append path "/.references"))))
|
|
|
|
(define* (remote-store-item-exists? host remote-item #:key (user "root") (port "22") (identity-file #f))
|
|
(apply command-success?
|
|
"ssh"
|
|
(append (ssh-base-args host #:user user #:port port #:identity-file identity-file)
|
|
(list "test" "-e" remote-item))))
|
|
|
|
(define* (copy-store-item-to-remote item host remote-store-dir #:key (user "root") (port "22") (identity-file #f))
|
|
(let* ((item-parent (dirname item))
|
|
(item-base (path-basename item))
|
|
(remote-command (string-append "set -eu; mkdir -p " (shell-quote remote-store-dir)
|
|
" && tar -xpf - -C " (shell-quote remote-store-dir)))
|
|
(command (string-append
|
|
"tar -cpf - -C " (shell-quote item-parent) " " (shell-quote item-base)
|
|
" | "
|
|
(ssh-command-prefix host #:user user #:port port #:identity-file identity-file)
|
|
" " (shell-quote remote-command))))
|
|
(run-command "sh" "-eu" "-c" command)))
|
|
|
|
(define* (wait-for-ssh host #:key (user "root") (port "22") (identity-file #f) (attempts 120) (delay 2))
|
|
(let loop ((remaining attempts))
|
|
(cond
|
|
((ssh-shell-success? host "service sshd onestatus >/dev/null 2>&1"
|
|
#:user user #:port port #:identity-file identity-file)
|
|
#t)
|
|
((<= remaining 0)
|
|
#f)
|
|
(else
|
|
(sleep delay)
|
|
(loop (- remaining 1))))))
|
|
|
|
(define* (deploy-system-closure closure-path host #:key (store-dir "/frx/store")
|
|
(user "root") (port "22") (identity-file #f)
|
|
(reboot? #f))
|
|
(let* ((local-store-dir (dirname closure-path))
|
|
(_ (unless (string=? local-store-dir store-dir)
|
|
(error "deploy expects closure to live under the selected store-dir" closure-path store-dir)))
|
|
(remote-closure-path (string-append store-dir "/" (path-basename closure-path)))
|
|
(references (store-reference-closure (list closure-path)))
|
|
(transferred '())
|
|
(skipped '()))
|
|
(unless (ssh-shell-success? host "test -x /usr/local/bin/fruix"
|
|
#:user user #:port port #:identity-file identity-file)
|
|
(error "remote target is missing /usr/local/bin/fruix" host))
|
|
(for-each
|
|
(lambda (item)
|
|
(let ((remote-item (string-append store-dir "/" (path-basename item))))
|
|
(if (remote-store-item-exists? host remote-item
|
|
#:user user #:port port #:identity-file identity-file)
|
|
(set! skipped (cons remote-item skipped))
|
|
(begin
|
|
(copy-store-item-to-remote item host store-dir
|
|
#:user user #:port port #:identity-file identity-file)
|
|
(set! transferred (cons remote-item transferred))))))
|
|
references)
|
|
(let* ((switch-output
|
|
(ssh-shell-output host
|
|
(string-append "/usr/local/bin/fruix system switch "
|
|
(shell-quote remote-closure-path))
|
|
#:user user #:port port #:identity-file identity-file))
|
|
(deploy-current-generation (or (metadata-value switch-output "current_generation") ""))
|
|
(deploy-current-closure (or (metadata-value switch-output "current_closure") ""))
|
|
(deploy-rollback-generation (or (metadata-value switch-output "rollback_generation") ""))
|
|
(deploy-rollback-closure (or (metadata-value switch-output "rollback_closure") ""))
|
|
(reboot-completed? #f)
|
|
(remote-hostname "")
|
|
(remote-run-current "")
|
|
(remote-status-output switch-output))
|
|
(when reboot?
|
|
(apply system* "ssh"
|
|
(append (ssh-base-args host #:user user #:port port #:identity-file identity-file)
|
|
(list "set -eu; shutdown -r now >/dev/null 2>&1 || reboot >/dev/null 2>&1 || true")))
|
|
(sleep 5)
|
|
(unless (wait-for-ssh host #:user user #:port port #:identity-file identity-file)
|
|
(error "remote target did not return over SSH after deploy reboot" host))
|
|
(set! reboot-completed? #t)
|
|
(set! remote-hostname
|
|
(ssh-shell-output host "hostname" #:user user #:port port #:identity-file identity-file))
|
|
(set! remote-run-current
|
|
(ssh-shell-output host "readlink /run/current-system" #:user user #:port port #:identity-file identity-file))
|
|
(set! remote-status-output
|
|
(ssh-shell-output host "/usr/local/bin/fruix system status"
|
|
#:user user #:port port #:identity-file identity-file)))
|
|
`((target-host . ,host)
|
|
(target-user . ,user)
|
|
(target-port . ,port)
|
|
(identity-file . ,(or identity-file ""))
|
|
(local-store-dir . ,store-dir)
|
|
(local-closure-path . ,closure-path)
|
|
(remote-closure-path . ,remote-closure-path)
|
|
(reference-count . ,(length references))
|
|
(transfer-item-count . ,(length transferred))
|
|
(skipped-item-count . ,(length skipped))
|
|
(transferred-items . ,(reverse transferred))
|
|
(skipped-items . ,(reverse skipped))
|
|
(switch-output . ,switch-output)
|
|
(deploy-current-generation . ,deploy-current-generation)
|
|
(deploy-current-closure . ,deploy-current-closure)
|
|
(deploy-rollback-generation . ,deploy-rollback-generation)
|
|
(deploy-rollback-closure . ,deploy-rollback-closure)
|
|
(reboot-requested . ,reboot?)
|
|
(reboot-completed . ,reboot-completed?)
|
|
(remote-hostname . ,remote-hostname)
|
|
(remote-run-current . ,remote-run-current)
|
|
(remote-status-output . ,remote-status-output)))))
|
|
|
|
(define (emit-system-deploy-metadata source-kind source-value os-file resolved-symbol store-dir result)
|
|
(emit-metadata
|
|
`((action . "deploy")
|
|
(source_kind . ,source-kind)
|
|
(source_value . ,source-value)
|
|
(os_file . ,(or os-file ""))
|
|
(system_variable . ,(or resolved-symbol ""))
|
|
(store_dir . ,store-dir)
|
|
(closure_path . ,(assoc-ref result 'local-closure-path))
|
|
(remote_closure_path . ,(assoc-ref result 'remote-closure-path))
|
|
(target_host . ,(assoc-ref result 'target-host))
|
|
(target_user . ,(assoc-ref result 'target-user))
|
|
(target_port . ,(assoc-ref result 'target-port))
|
|
(identity_file . ,(assoc-ref result 'identity-file))
|
|
(reference_count . ,(assoc-ref result 'reference-count))
|
|
(transfer_item_count . ,(assoc-ref result 'transfer-item-count))
|
|
(skipped_item_count . ,(assoc-ref result 'skipped-item-count))
|
|
(deploy_current_generation . ,(assoc-ref result 'deploy-current-generation))
|
|
(deploy_current_closure . ,(assoc-ref result 'deploy-current-closure))
|
|
(deploy_rollback_generation . ,(assoc-ref result 'deploy-rollback-generation))
|
|
(deploy_rollback_closure . ,(assoc-ref result 'deploy-rollback-closure))
|
|
(reboot_requested . ,(assoc-ref result 'reboot-requested))
|
|
(reboot_completed . ,(assoc-ref result 'reboot-completed))
|
|
(remote_hostname . ,(assoc-ref result 'remote-hostname))
|
|
(remote_run_current . ,(assoc-ref result 'remote-run-current)))))
|
|
|
|
(define (main argv)
|
|
(let* ((parsed (parse-arguments argv))
|
|
(command (assoc-ref parsed 'command))
|
|
(action (assoc-ref parsed 'action))
|
|
(store-dir (assoc-ref parsed 'store-dir)))
|
|
(cond
|
|
((string=? command "system")
|
|
(let* ((positional (assoc-ref parsed 'positional))
|
|
(disk-capacity (assoc-ref parsed 'disk-capacity))
|
|
(root-size (assoc-ref parsed 'root-size))
|
|
(target-opt (assoc-ref parsed 'target))
|
|
(install-target-device (assoc-ref parsed 'install-target-device))
|
|
(rootfs-opt (assoc-ref parsed 'rootfs))
|
|
(deploy-host-opt (assoc-ref parsed 'deploy-host))
|
|
(deploy-user (assoc-ref parsed 'deploy-user))
|
|
(deploy-port (assoc-ref parsed 'deploy-port))
|
|
(identity-file (assoc-ref parsed 'identity-file))
|
|
(reboot? (assoc-ref parsed 'reboot?))
|
|
(self-test? (assoc-ref parsed 'self-test?))
|
|
(system-name (assoc-ref parsed 'system-name))
|
|
(requested-symbol (and system-name (string->symbol system-name))))
|
|
(unless (member action '("build" "deploy" "image" "installer" "installer-iso" "installer-tui" "install" "rootfs"))
|
|
(error "unknown system action" action))
|
|
(let* ((deploy-host (or deploy-host-opt
|
|
(and (string=? action "deploy")
|
|
(match positional
|
|
((host . _) host)
|
|
(_ #f)))))
|
|
(os-file (and (not (string=? action "deploy"))
|
|
(match positional
|
|
((file . _) file)
|
|
(() (error "missing operating-system file argument")))))
|
|
(target (or target-opt
|
|
(and (string=? action "install")
|
|
(match positional
|
|
((_ target-path) target-path)
|
|
(_ #f)))))
|
|
(rootfs (or rootfs-opt
|
|
(and (string=? action "rootfs")
|
|
(match positional
|
|
((_ dir) dir)
|
|
((_ _ dir . _) dir)
|
|
(_ #f))))))
|
|
(cond
|
|
((string=? action "deploy")
|
|
(unless deploy-host
|
|
(error "deploy action requires TARGET or --host HOST"))
|
|
(let* ((deploy-source (match positional
|
|
((_ source . _) source)
|
|
((_ _ source . _) source)
|
|
(_ #f)))
|
|
(guile-prefix (or (getenv "GUILE_PREFIX") "/tmp/guile-freebsd-validate-install"))
|
|
(guile-extra-prefix (or (getenv "GUILE_EXTRA_PREFIX") "/tmp/guile-gnutls-freebsd-validate-install"))
|
|
(shepherd-prefix (or (getenv "SHEPHERD_PREFIX") "/tmp/shepherd-freebsd-validate-install"))
|
|
(guile-store-path (getenv "FRUIX_GUILE_STORE"))
|
|
(guile-extra-store-path (getenv "FRUIX_GUILE_EXTRA_STORE"))
|
|
(shepherd-store-path (getenv "FRUIX_SHEPHERD_STORE"))
|
|
(guile-newt-store-path (getenv "FRUIX_GUILE_NEWT_STORE")))
|
|
(unless deploy-source
|
|
(error "deploy action requires a declaration file or system closure path"))
|
|
(if (system-closure-path? deploy-source)
|
|
(emit-system-deploy-metadata
|
|
"closure" deploy-source #f #f store-dir
|
|
(deploy-system-closure deploy-source deploy-host
|
|
#:store-dir store-dir
|
|
#:user deploy-user
|
|
#:port deploy-port
|
|
#:identity-file identity-file
|
|
#:reboot? reboot?))
|
|
(call-with-values
|
|
(lambda ()
|
|
(load-operating-system-from-file deploy-source requested-symbol))
|
|
(lambda (os resolved-symbol)
|
|
(let* ((declaration-source (read-file-string deploy-source))
|
|
(build-result
|
|
(materialize-operating-system os
|
|
#:store-dir store-dir
|
|
#:guile-prefix guile-prefix
|
|
#:guile-extra-prefix guile-extra-prefix
|
|
#:shepherd-prefix shepherd-prefix
|
|
#:guile-store-path guile-store-path
|
|
#:guile-extra-store-path guile-extra-store-path
|
|
#:shepherd-store-path shepherd-store-path
|
|
#:guile-newt-store-path guile-newt-store-path
|
|
#:declaration-source declaration-source
|
|
#:declaration-origin deploy-source
|
|
#:declaration-system-symbol resolved-symbol)))
|
|
(emit-system-deploy-metadata
|
|
"declaration" deploy-source deploy-source resolved-symbol store-dir
|
|
(deploy-system-closure (assoc-ref build-result 'closure-path) deploy-host
|
|
#:store-dir store-dir
|
|
#:user deploy-user
|
|
#:port deploy-port
|
|
#:identity-file identity-file
|
|
#:reboot? reboot?))))))))
|
|
((not (string=? action "deploy"))
|
|
(call-with-values
|
|
(lambda ()
|
|
(load-operating-system-from-file os-file requested-symbol))
|
|
(lambda (os resolved-symbol)
|
|
(let* ((guile-prefix (or (getenv "GUILE_PREFIX") "/tmp/guile-freebsd-validate-install"))
|
|
(guile-extra-prefix (or (getenv "GUILE_EXTRA_PREFIX") "/tmp/guile-gnutls-freebsd-validate-install"))
|
|
(shepherd-prefix (or (getenv "SHEPHERD_PREFIX") "/tmp/shepherd-freebsd-validate-install"))
|
|
(guile-store-path (getenv "FRUIX_GUILE_STORE"))
|
|
(guile-extra-store-path (getenv "FRUIX_GUILE_EXTRA_STORE"))
|
|
(shepherd-store-path (getenv "FRUIX_SHEPHERD_STORE"))
|
|
(guile-newt-store-path (getenv "FRUIX_GUILE_NEWT_STORE"))
|
|
(declaration-source (read-file-string os-file)))
|
|
(cond
|
|
((string=? action "build")
|
|
(emit-system-build-metadata
|
|
os-file resolved-symbol store-dir os
|
|
(materialize-operating-system os
|
|
#:store-dir store-dir
|
|
#:guile-prefix guile-prefix
|
|
#:guile-extra-prefix guile-extra-prefix
|
|
#:shepherd-prefix shepherd-prefix
|
|
#:guile-store-path guile-store-path
|
|
#:guile-extra-store-path guile-extra-store-path
|
|
#:shepherd-store-path shepherd-store-path
|
|
#:guile-newt-store-path guile-newt-store-path
|
|
#:declaration-source declaration-source
|
|
#:declaration-origin os-file
|
|
#:declaration-system-symbol resolved-symbol)))
|
|
((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
|
|
#:declaration-source declaration-source
|
|
#:declaration-origin os-file
|
|
#:declaration-system-symbol resolved-symbol)))
|
|
(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
|
|
#:declaration-source declaration-source
|
|
#:declaration-origin os-file
|
|
#:declaration-system-symbol resolved-symbol
|
|
#: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
|
|
#:declaration-source declaration-source
|
|
#:declaration-origin os-file
|
|
#:declaration-system-symbol resolved-symbol
|
|
#:install-target-device (or install-target-device "/dev/vtbd1")
|
|
#:root-size (or root-size "10g")
|
|
#:disk-capacity disk-capacity)))
|
|
((string=? action "installer-iso")
|
|
(emit-system-installer-iso-metadata
|
|
os-file resolved-symbol store-dir os
|
|
(materialize-installer-iso os
|
|
#:store-dir store-dir
|
|
#:guile-prefix guile-prefix
|
|
#:guile-extra-prefix guile-extra-prefix
|
|
#:shepherd-prefix shepherd-prefix
|
|
#:declaration-source declaration-source
|
|
#:declaration-origin os-file
|
|
#:declaration-system-symbol resolved-symbol
|
|
#:install-target-device (or install-target-device "/dev/vtbd0")
|
|
#:root-size root-size)))
|
|
((string=? action "installer-tui")
|
|
(let* ((seed-target-device (or install-target-device
|
|
(and target
|
|
(string-prefix? "/dev/" target)
|
|
target)))
|
|
(state (operating-system->installer-state os
|
|
#:target-device seed-target-device
|
|
#:root-size root-size
|
|
#:disk-capacity disk-capacity))
|
|
(result (if self-test?
|
|
(run-newt-self-test)
|
|
(run-newt-installer state))))
|
|
(emit-installer-tui-metadata
|
|
os-file resolved-symbol store-dir state result)))
|
|
((string=? action "install")
|
|
(unless target
|
|
(error "install action requires TARGET or --target PATH"))
|
|
(emit-system-install-metadata
|
|
os-file resolved-symbol store-dir os
|
|
(install-operating-system os
|
|
#:target target
|
|
#:store-dir store-dir
|
|
#:guile-prefix guile-prefix
|
|
#:guile-extra-prefix guile-extra-prefix
|
|
#:shepherd-prefix shepherd-prefix
|
|
#:declaration-source declaration-source
|
|
#:declaration-origin os-file
|
|
#:declaration-system-symbol resolved-symbol
|
|
#:root-size root-size
|
|
#:disk-capacity disk-capacity))))))))))))
|
|
((string=? command "package")
|
|
(let* ((positional (assoc-ref parsed 'positional))
|
|
(profile-dir (or (assoc-ref parsed 'profile-dir)
|
|
(default-package-profile-dir)))
|
|
(name-or-query (match positional
|
|
((value . _) value)
|
|
(() #f))))
|
|
(unless (member action '("list" "search" "show" "build" "installed" "install" "remove"))
|
|
(error "unknown package action" action))
|
|
(cond
|
|
((string=? action "list")
|
|
(for-each (lambda (package)
|
|
(format #t "~a~%" (package-summary-line package)))
|
|
(all-freebsd-packages)))
|
|
((string=? action "search")
|
|
(unless name-or-query
|
|
(error "package search requires QUERY"))
|
|
(for-each (lambda (package)
|
|
(format #t "~a~%" (package-summary-line package)))
|
|
(search-freebsd-packages name-or-query)))
|
|
((string=? action "show")
|
|
(unless name-or-query
|
|
(error "package show requires NAME"))
|
|
(let ((package (find-freebsd-package name-or-query)))
|
|
(unless package
|
|
(error "unknown package" name-or-query))
|
|
(emit-package-show-metadata package)))
|
|
((string=? action "build")
|
|
(unless name-or-query
|
|
(error "package build requires NAME"))
|
|
(let ((package (find-freebsd-package name-or-query)))
|
|
(unless package
|
|
(error "unknown package" name-or-query))
|
|
(emit-package-build-metadata
|
|
store-dir package
|
|
(materialize-freebsd-package package
|
|
store-dir
|
|
(make-hash-table)
|
|
(make-hash-table)))))
|
|
((string=? action "installed")
|
|
(for-each (lambda (name)
|
|
(let ((package (find-freebsd-package name)))
|
|
(if package
|
|
(format #t "~a~%" (package-summary-line package))
|
|
(format #t "~a\tunknown\tunknown\tUnknown package recorded in profile\n" name))))
|
|
(package-profile-package-names profile-dir)))
|
|
((string=? action "install")
|
|
(unless (pair? positional)
|
|
(error "package install requires at least one package name"))
|
|
(emit-package-profile-metadata
|
|
"package-install"
|
|
store-dir
|
|
(update-package-profile profile-dir
|
|
store-dir
|
|
(append (package-profile-package-names profile-dir)
|
|
positional))))
|
|
((string=? action "remove")
|
|
(unless (pair? positional)
|
|
(error "package remove requires at least one package name"))
|
|
(let ((removals (normalize-package-names positional)))
|
|
(emit-package-profile-metadata
|
|
"package-remove"
|
|
store-dir
|
|
(update-package-profile profile-dir
|
|
store-dir
|
|
(filter (lambda (name)
|
|
(not (member name removals)))
|
|
(package-profile-package-names profile-dir)))))))))
|
|
((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
|
|
`((action . "materialize")
|
|
(source_file . ,source-file)
|
|
(source_variable . ,resolved-symbol)
|
|
(store_dir . ,store-dir)
|
|
(cache_dir . ,cache-dir)
|
|
(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) ""))
|
|
(materialized_source_store . ,(assoc-ref result 'source-store-path))
|
|
(materialized_source_root . ,(assoc-ref result 'source-root))
|
|
(materialized_source_info_file . ,(assoc-ref result 'source-info-file))
|
|
(materialized_source_tree_sha256 . ,(assoc-ref result 'source-tree-sha256))
|
|
(materialized_source_cache_path . ,(or (assoc-ref result 'cache-path) ""))
|
|
(materialized_source_kind . ,(assoc-ref effective 'kind))
|
|
(materialized_source_url . ,(or (assoc-ref effective 'url) ""))
|
|
(materialized_source_path . ,(or (assoc-ref effective 'path) ""))
|
|
(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)))))
|
|
(#t
|
|
(usage 1)))))
|
|
|
|
(main (command-line))
|