534 lines
28 KiB
Scheme
534 lines
28 KiB
Scheme
#!/tmp/guile-freebsd-validate-install/bin/guile -s
|
|
!#
|
|
|
|
(use-modules (fruix system freebsd)
|
|
(fruix packages freebsd)
|
|
(ice-9 format)
|
|
(ice-9 match)
|
|
(srfi srfi-1)
|
|
(srfi srfi-13))
|
|
|
|
(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\
|
|
source ACTION ... Fetch or snapshot declarative FreeBSD source inputs.\n\
|
|
\n\
|
|
System actions:\n\
|
|
build Materialize the Fruix system closure in /frx/store.\n\
|
|
image Materialize the Fruix disk image in /frx/store.\n\
|
|
install Install the Fruix system onto --target PATH.\n\
|
|
rootfs Materialize a rootfs tree at --rootfs DIR or ROOTFS-DIR.\n\
|
|
\n\
|
|
System options:\n\
|
|
--system NAME Scheme variable holding the operating-system object.\n\
|
|
--store DIR Store directory to use (default: /frx/store).\n\
|
|
--disk-capacity SIZE Disk capacity for 'image' or raw-file 'install' targets.\n\
|
|
--root-size SIZE Root filesystem size for 'image' or 'install' (example: 6g).\n\
|
|
--target PATH Install target for 'install' (raw image file or /dev/... device).\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))
|
|
|
|
(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 (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)
|
|
(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)
|
|
(target . ,target)
|
|
(rootfs . ,rootfs))))
|
|
(("--help")
|
|
(usage 0))
|
|
(((? (lambda (arg) (string-prefix? "--system=" arg)) arg) . tail)
|
|
(loop tail positional (option-value arg "--system=") store-dir disk-capacity root-size target rootfs))
|
|
(("--system" value . tail)
|
|
(loop tail positional value store-dir disk-capacity root-size target rootfs))
|
|
(((? (lambda (arg) (string-prefix? "--store=" arg)) arg) . tail)
|
|
(loop tail positional system-name (option-value arg "--store=") disk-capacity root-size target rootfs))
|
|
(("--store" value . tail)
|
|
(loop tail positional system-name value disk-capacity root-size target rootfs))
|
|
(((? (lambda (arg) (string-prefix? "--disk-capacity=" arg)) arg) . tail)
|
|
(loop tail positional system-name store-dir (option-value arg "--disk-capacity=") root-size target rootfs))
|
|
(("--disk-capacity" value . tail)
|
|
(loop tail positional system-name store-dir value root-size target rootfs))
|
|
(((? (lambda (arg) (string-prefix? "--root-size=" arg)) arg) . tail)
|
|
(loop tail positional system-name store-dir disk-capacity (option-value arg "--root-size=") target rootfs))
|
|
(("--root-size" value . tail)
|
|
(loop tail positional system-name store-dir disk-capacity value target rootfs))
|
|
(((? (lambda (arg) (string-prefix? "--target=" arg)) arg) . tail)
|
|
(loop tail positional system-name store-dir disk-capacity root-size (option-value arg "--target=") rootfs))
|
|
(("--target" value . tail)
|
|
(loop tail positional system-name store-dir disk-capacity root-size value rootfs))
|
|
(((? (lambda (arg) (string-prefix? "--rootfs=" arg)) arg) . tail)
|
|
(loop tail positional system-name store-dir disk-capacity root-size target (option-value arg "--rootfs=")))
|
|
(("--rootfs" value . tail)
|
|
(loop tail positional system-name store-dir disk-capacity root-size target value))
|
|
(((? (lambda (arg) (string-prefix? "--" arg)) arg) . _)
|
|
(error "unknown option" arg))
|
|
((arg . tail)
|
|
(loop tail (cons arg positional) system-name store-dir disk-capacity root-size target rootfs)))))
|
|
|
|
(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)
|
|
(match argv
|
|
((_)
|
|
(usage 1))
|
|
((_ "--help")
|
|
(usage 0))
|
|
((_ "help")
|
|
(usage 0))
|
|
((_ "system" "--help")
|
|
(usage 0))
|
|
((_ "source" "--help")
|
|
(usage 0))
|
|
((_ "system" action . rest)
|
|
(parse-system-arguments action rest))
|
|
((_ "source" action . rest)
|
|
(parse-source-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))
|
|
(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))
|
|
(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)
|
|
(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))
|
|
(rootfs-opt (assoc-ref parsed 'rootfs))
|
|
(system-name (assoc-ref parsed 'system-name))
|
|
(requested-symbol (and system-name (string->symbol system-name))))
|
|
(unless (member action '("build" "image" "install" "rootfs"))
|
|
(error "unknown system action" action))
|
|
(let* ((os-file (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))))))
|
|
(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")))
|
|
(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)))
|
|
((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=? 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
|
|
#:root-size root-size
|
|
#: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
|
|
`((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) ""))))))))))
|
|
(else
|
|
(usage 1)))))
|
|
|
|
(main (command-line))
|