#!/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\ installer Materialize a bootable Fruix installer image in /frx/store.\n\ installer-iso Materialize a bootable Fruix installer ISO 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', '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\ --install-target-device DEVICE\n\ Target block device used by the booted 'installer' environment.\n\ --rootfs DIR Rootfs target for 'rootfs'.\n\ \n\ Source actions:\n\ 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) (install-target-device #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) (install-target-device . ,install-target-device) (rootfs . ,rootfs)))) (("--help") (usage 0)) (((? (lambda (arg) (string-prefix? "--system=" arg)) arg) . tail) (loop tail positional (option-value arg "--system=") store-dir disk-capacity root-size target install-target-device rootfs)) (("--system" value . tail) (loop tail positional value store-dir disk-capacity root-size target install-target-device rootfs)) (((? (lambda (arg) (string-prefix? "--store=" arg)) arg) . tail) (loop tail positional system-name (option-value arg "--store=") disk-capacity root-size target install-target-device rootfs)) (("--store" value . tail) (loop tail positional system-name value disk-capacity root-size target install-target-device rootfs)) (((? (lambda (arg) (string-prefix? "--disk-capacity=" arg)) arg) . tail) (loop tail positional system-name store-dir (option-value arg "--disk-capacity=") root-size target install-target-device rootfs)) (("--disk-capacity" value . tail) (loop tail positional system-name store-dir value root-size target install-target-device rootfs)) (((? (lambda (arg) (string-prefix? "--root-size=" arg)) arg) . tail) (loop tail positional system-name store-dir disk-capacity (option-value arg "--root-size=") target install-target-device rootfs)) (("--root-size" value . tail) (loop tail positional system-name store-dir disk-capacity value target install-target-device rootfs)) (((? (lambda (arg) (string-prefix? "--target=" arg)) arg) . tail) (loop tail positional system-name store-dir disk-capacity root-size (option-value arg "--target=") install-target-device rootfs)) (("--target" value . tail) (loop tail positional system-name store-dir disk-capacity root-size value install-target-device rootfs)) (((? (lambda (arg) (string-prefix? "--install-target-device=" arg)) arg) . tail) (loop tail positional system-name store-dir disk-capacity root-size target (option-value arg "--install-target-device=") rootfs)) (("--install-target-device" value . tail) (loop tail positional system-name store-dir disk-capacity root-size target value rootfs)) (((? (lambda (arg) (string-prefix? "--rootfs=" arg)) arg) . tail) (loop tail positional system-name store-dir disk-capacity root-size target install-target-device (option-value arg "--rootfs="))) (("--rootfs" value . tail) (loop tail positional system-name store-dir disk-capacity root-size target install-target-device value)) (((? (lambda (arg) (string-prefix? "--" arg)) arg) . _) (error "unknown option" arg)) ((arg . tail) (loop tail (cons arg positional) system-name store-dir disk-capacity root-size target install-target-device 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 (emit-system-installer-metadata os-file resolved-symbol store-dir os result) (let* ((installer-image-spec (assoc-ref result 'installer-image-spec)) (image-spec (assoc-ref result 'image-spec)) (store-items (assoc-ref result 'store-items)) (target-store-items (assoc-ref result 'target-store-items)) (installer-store-items (assoc-ref result 'installer-store-items)) (host-base-stores (assoc-ref result 'host-base-stores)) (native-base-stores (assoc-ref result 'native-base-stores)) (fruix-runtime-stores (assoc-ref result 'fruix-runtime-stores)) (base (operating-system-freebsd-base os)) (source (freebsd-base-source base)) (host-provenance (call-with-input-file (assoc-ref result 'host-base-provenance-file) read))) (emit-metadata `((action . "installer") (os_file . ,os-file) (system_variable . ,resolved-symbol) (store_dir . ,store-dir) (freebsd_base_name . ,(freebsd-base-name base)) (freebsd_base_version_label . ,(freebsd-base-version-label base)) (freebsd_base_release . ,(freebsd-base-release base)) (freebsd_base_branch . ,(freebsd-base-branch base)) (freebsd_base_source_root . ,(freebsd-base-source-root base)) (freebsd_base_target . ,(freebsd-base-target base)) (freebsd_base_target_arch . ,(freebsd-base-target-arch base)) (freebsd_base_kernconf . ,(freebsd-base-kernconf base)) (freebsd_base_file . ,(assoc-ref result 'freebsd-base-file)) (freebsd_source_name . ,(freebsd-source-name source)) (freebsd_source_kind . ,(freebsd-source-kind source)) (freebsd_source_url . ,(or (freebsd-source-url source) "")) (freebsd_source_path . ,(or (freebsd-source-path source) "")) (freebsd_source_ref . ,(or (freebsd-source-ref source) "")) (freebsd_source_commit . ,(or (freebsd-source-commit source) "")) (freebsd_source_sha256 . ,(or (freebsd-source-sha256 source) "")) (freebsd_source_file . ,(assoc-ref result 'freebsd-source-file)) (freebsd_source_materializations_file . ,(assoc-ref result 'freebsd-source-materializations-file)) (materialized_source_store_count . ,(length (assoc-ref result 'materialized-source-stores))) (materialized_source_stores . ,(string-join (assoc-ref result 'materialized-source-stores) ",")) (disk_capacity . ,(assoc-ref image-spec 'disk-capacity)) (root_size . ,(assoc-ref image-spec 'root-size)) (installer_host_name . ,(assoc-ref installer-image-spec 'installer-host-name)) (install_target_device . ,(assoc-ref result 'install-target-device)) (installer_state_path . ,(assoc-ref result 'installer-state-path)) (installer_log_path . ,(assoc-ref result 'installer-log-path)) (image_store_path . ,(assoc-ref result 'image-store-path)) (disk_image . ,(assoc-ref result 'disk-image)) (esp_image . ,(assoc-ref result 'esp-image)) (root_image . ,(assoc-ref result 'root-image)) (installer_closure_path . ,(assoc-ref result 'installer-closure-path)) (target_closure_path . ,(assoc-ref result 'target-closure-path)) (host_base_store_count . ,(length host-base-stores)) (host_base_stores . ,(string-join host-base-stores ",")) (native_base_store_count . ,(length native-base-stores)) (native_base_stores . ,(string-join native-base-stores ",")) (fruix_runtime_store_count . ,(length fruix-runtime-stores)) (fruix_runtime_stores . ,(string-join fruix-runtime-stores ",")) (host_base_provenance_file . ,(assoc-ref result 'host-base-provenance-file)) (store_layout_file . ,(assoc-ref result 'store-layout-file)) (host_freebsd_version . ,(assoc-ref host-provenance 'freebsd-version-kru)) (host_uname . ,(assoc-ref host-provenance 'uname)) (usr_src_git_revision . ,(assoc-ref host-provenance 'usr-src-git-revision)) (usr_src_git_branch . ,(assoc-ref host-provenance 'usr-src-git-branch)) (usr_src_newvers_sha256 . ,(assoc-ref host-provenance 'usr-src-newvers-sha256)) (store_item_count . ,(length store-items)) (target_store_item_count . ,(length target-store-items)) (installer_store_item_count . ,(length installer-store-items)))))) (define (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)) (installer_closure_path . ,(assoc-ref result 'installer-closure-path)) (target_closure_path . ,(assoc-ref result 'target-closure-path)) (host_base_store_count . ,(length host-base-stores)) (host_base_stores . ,(string-join host-base-stores ",")) (native_base_store_count . ,(length native-base-stores)) (native_base_stores . ,(string-join native-base-stores ",")) (fruix_runtime_store_count . ,(length fruix-runtime-stores)) (fruix_runtime_stores . ,(string-join fruix-runtime-stores ",")) (host_base_provenance_file . ,(assoc-ref result 'host-base-provenance-file)) (store_layout_file . ,(assoc-ref result 'store-layout-file)) (host_freebsd_version . ,(assoc-ref host-provenance 'freebsd-version-kru)) (host_uname . ,(assoc-ref host-provenance 'uname)) (usr_src_git_revision . ,(assoc-ref host-provenance 'usr-src-git-revision)) (usr_src_git_branch . ,(assoc-ref host-provenance 'usr-src-git-branch)) (usr_src_newvers_sha256 . ,(assoc-ref host-provenance 'usr-src-newvers-sha256)) (store_item_count . ,(length store-items)) (target_store_item_count . ,(length target-store-items)) (installer_store_item_count . ,(length installer-store-items)))))) (define (main argv) (let* ((parsed (parse-arguments argv)) (command (assoc-ref parsed 'command)) (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)) (system-name (assoc-ref parsed 'system-name)) (requested-symbol (and system-name (string->symbol system-name)))) (unless (member action '("build" "image" "installer" "installer-iso" "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 "installer") (emit-system-installer-metadata os-file resolved-symbol store-dir os (materialize-installer-image os #:store-dir store-dir #:guile-prefix guile-prefix #:guile-extra-prefix guile-extra-prefix #:shepherd-prefix shepherd-prefix #:install-target-device (or install-target-device "/dev/vtbd1") #:root-size (or root-size "10g") #:disk-capacity disk-capacity))) ((string=? action "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 #:install-target-device (or install-target-device "/dev/vtbd0") #:root-size root-size))) ((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))