250 lines
13 KiB
Scheme
250 lines
13 KiB
Scheme
#!/tmp/guile-freebsd-validate-install/bin/guile -s
|
|
!#
|
|
|
|
(use-modules (fruix system 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 system ACTION OS-FILE [OPTIONS]\n\
|
|
\n\
|
|
Actions:\n\
|
|
build Materialize the Fruix system closure in /frx/store.\n\
|
|
image Materialize the Fruix disk image in /frx/store.\n\
|
|
rootfs Materialize a rootfs tree at --rootfs DIR or ROOTFS-DIR.\n\
|
|
\n\
|
|
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' (example: 30g).\n\
|
|
--rootfs DIR Rootfs target for 'rootfs'.\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
|
|
phase10-operating-system
|
|
phase9-operating-system
|
|
phase8-operating-system
|
|
phase7-operating-system
|
|
default-operating-system
|
|
os))
|
|
|
|
(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 (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 (parse-arguments argv)
|
|
(match argv
|
|
((_)
|
|
(usage 1))
|
|
((_ "--help")
|
|
(usage 0))
|
|
((_ "help")
|
|
(usage 0))
|
|
((_ "system" "--help")
|
|
(usage 0))
|
|
((_ "system" action . rest)
|
|
(let loop ((args rest)
|
|
(positional '())
|
|
(system-name #f)
|
|
(store-dir "/frx/store")
|
|
(disk-capacity #f)
|
|
(rootfs #f))
|
|
(match args
|
|
(()
|
|
(let ((positional (reverse positional)))
|
|
`((action . ,action)
|
|
(positional . ,positional)
|
|
(system-name . ,system-name)
|
|
(store-dir . ,store-dir)
|
|
(disk-capacity . ,disk-capacity)
|
|
(rootfs . ,rootfs))))
|
|
(("--help")
|
|
(usage 0))
|
|
(((? (lambda (arg) (string-prefix? "--system=" arg)) arg) . tail)
|
|
(loop tail positional (option-value arg "--system=") store-dir disk-capacity rootfs))
|
|
(("--system" value . tail)
|
|
(loop tail positional value store-dir disk-capacity rootfs))
|
|
(((? (lambda (arg) (string-prefix? "--store=" arg)) arg) . tail)
|
|
(loop tail positional system-name (option-value arg "--store=") disk-capacity rootfs))
|
|
(("--store" value . tail)
|
|
(loop tail positional system-name value disk-capacity rootfs))
|
|
(((? (lambda (arg) (string-prefix? "--disk-capacity=" arg)) arg) . tail)
|
|
(loop tail positional system-name store-dir (option-value arg "--disk-capacity=") rootfs))
|
|
(("--disk-capacity" value . tail)
|
|
(loop tail positional system-name store-dir value rootfs))
|
|
(((? (lambda (arg) (string-prefix? "--rootfs=" arg)) arg) . tail)
|
|
(loop tail positional system-name store-dir disk-capacity (option-value arg "--rootfs=")))
|
|
(("--rootfs" value . tail)
|
|
(loop tail positional system-name store-dir disk-capacity value))
|
|
(((? (lambda (arg) (string-prefix? "--" arg)) arg) . _)
|
|
(error "unknown option" arg))
|
|
((arg . tail)
|
|
(loop tail (cons arg positional) system-name store-dir disk-capacity rootfs)))))
|
|
((_ . _)
|
|
(usage 1))))
|
|
|
|
(define (main argv)
|
|
(let* ((parsed (parse-arguments argv))
|
|
(action (assoc-ref parsed 'action))
|
|
(positional (assoc-ref parsed 'positional))
|
|
(store-dir (assoc-ref parsed 'store-dir))
|
|
(disk-capacity (assoc-ref parsed 'disk-capacity))
|
|
(rootfs-opt (assoc-ref parsed 'rootfs))
|
|
(system-name (assoc-ref parsed 'system-name))
|
|
(requested-symbol (and system-name (string->symbol system-name))))
|
|
(cond
|
|
((member action '("build" "image" "rootfs")) #t)
|
|
(else (error "unknown system action" action)))
|
|
(let* ((os-file (match positional
|
|
((file . _) file)
|
|
(() (error "missing operating-system file argument"))))
|
|
(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")
|
|
(let* ((result (materialize-operating-system os
|
|
#:store-dir store-dir
|
|
#:guile-prefix guile-prefix
|
|
#:guile-extra-prefix guile-extra-prefix
|
|
#:shepherd-prefix shepherd-prefix))
|
|
(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))
|
|
(fruix-runtime-stores (assoc-ref result 'fruix-runtime-stores))
|
|
(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)
|
|
(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 ","))
|
|
(fruix_runtime_store_count . ,(length fruix-runtime-stores))
|
|
(fruix_runtime_stores . ,(string-join fruix-runtime-stores ","))
|
|
(host_base_provenance_file . ,(assoc-ref result 'host-base-provenance-file))
|
|
(store_layout_file . ,(assoc-ref result 'store-layout-file))
|
|
(host_freebsd_version . ,(assoc-ref host-provenance 'freebsd-version-kru))
|
|
(host_uname . ,(assoc-ref host-provenance 'uname))
|
|
(usr_src_git_revision . ,(assoc-ref host-provenance 'usr-src-git-revision))
|
|
(usr_src_git_branch . ,(assoc-ref host-provenance 'usr-src-git-branch))
|
|
(usr_src_newvers_sha256 . ,(assoc-ref host-provenance 'usr-src-newvers-sha256))
|
|
(generated_file_count . ,(length generated-files))
|
|
(reference_count . ,(length references))))))
|
|
((string=? action "rootfs")
|
|
(unless rootfs
|
|
(error "rootfs action requires ROOTFS-DIR or --rootfs DIR"))
|
|
(let ((result (materialize-rootfs os rootfs
|
|
#:store-dir store-dir
|
|
#:guile-prefix guile-prefix
|
|
#:guile-extra-prefix guile-extra-prefix
|
|
#:shepherd-prefix shepherd-prefix)))
|
|
(emit-metadata
|
|
`((action . "rootfs")
|
|
(os_file . ,os-file)
|
|
(system_variable . ,resolved-symbol)
|
|
(store_dir . ,store-dir)
|
|
(rootfs . ,(assoc-ref result 'rootfs))
|
|
(closure_path . ,(assoc-ref result 'closure-path))
|
|
(ready_marker . ,(assoc-ref result 'ready-marker))
|
|
(rc_script . ,(assoc-ref result 'rc-script))))))
|
|
((string=? action "image")
|
|
(let* ((result (materialize-bhyve-image os
|
|
#:store-dir store-dir
|
|
#:guile-prefix guile-prefix
|
|
#:guile-extra-prefix guile-extra-prefix
|
|
#:shepherd-prefix shepherd-prefix
|
|
#:disk-capacity disk-capacity))
|
|
(image-spec (assoc-ref result 'image-spec))
|
|
(store-items (assoc-ref result 'store-items))
|
|
(host-base-stores (assoc-ref result 'host-base-stores))
|
|
(fruix-runtime-stores (assoc-ref result 'fruix-runtime-stores))
|
|
(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)
|
|
(disk_capacity . ,(assoc-ref image-spec 'disk-capacity))
|
|
(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 ","))
|
|
(fruix_runtime_store_count . ,(length fruix-runtime-stores))
|
|
(fruix_runtime_stores . ,(string-join fruix-runtime-stores ","))
|
|
(host_base_provenance_file . ,(assoc-ref result 'host-base-provenance-file))
|
|
(store_layout_file . ,(assoc-ref result 'store-layout-file))
|
|
(host_freebsd_version . ,(assoc-ref host-provenance 'freebsd-version-kru))
|
|
(host_uname . ,(assoc-ref host-provenance 'uname))
|
|
(usr_src_git_revision . ,(assoc-ref host-provenance 'usr-src-git-revision))
|
|
(usr_src_git_branch . ,(assoc-ref host-provenance 'usr-src-git-branch))
|
|
(usr_src_newvers_sha256 . ,(assoc-ref host-provenance 'usr-src-newvers-sha256))
|
|
(store_item_count . ,(length store-items)))))))))))))
|
|
|
|
(main (command-line))
|