From ebe064a6529f650a20afa1f30fe9a2d4cb4774cf Mon Sep 17 00:00:00 2001 From: Steffen Beyer Date: Sat, 4 Apr 2026 09:38:27 +0200 Subject: [PATCH] system: split FreeBSD system module --- modules/fruix/system/freebsd.scm | 2737 +---------------------- modules/fruix/system/freebsd/build.scm | 470 ++++ modules/fruix/system/freebsd/media.scm | 1031 +++++++++ modules/fruix/system/freebsd/model.scm | 334 +++ modules/fruix/system/freebsd/render.scm | 499 +++++ modules/fruix/system/freebsd/source.scm | 203 ++ modules/fruix/system/freebsd/utils.scm | 243 ++ 7 files changed, 2834 insertions(+), 2683 deletions(-) create mode 100644 modules/fruix/system/freebsd/build.scm create mode 100644 modules/fruix/system/freebsd/media.scm create mode 100644 modules/fruix/system/freebsd/model.scm create mode 100644 modules/fruix/system/freebsd/render.scm create mode 100644 modules/fruix/system/freebsd/source.scm create mode 100644 modules/fruix/system/freebsd/utils.scm diff --git a/modules/fruix/system/freebsd.scm b/modules/fruix/system/freebsd.scm index 6248bc9..4c0c8c7 100644 --- a/modules/fruix/system/freebsd.scm +++ b/modules/fruix/system/freebsd.scm @@ -1,2684 +1,55 @@ (define-module (fruix system freebsd) - #:use-module (fruix packages freebsd) - #:use-module (guix build utils) - #:use-module (ice-9 ftw) - #:use-module (ice-9 format) - #:use-module (ice-9 match) - #:use-module (ice-9 popen) - #:use-module (ice-9 hash-table) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-13) - #:use-module (rnrs io ports) - #:export (user-group - user-group? - user-group-name - user-group-gid - user-group-system? - user-account - user-account? - user-account-name - user-account-uid - user-account-group - user-account-supplementary-groups - user-account-comment - user-account-home - user-account-shell - user-account-system? - file-system - file-system? - file-system-device - file-system-mount-point - file-system-type - file-system-options - file-system-needed-for-boot? - operating-system - operating-system? - operating-system-host-name - operating-system-freebsd-base - operating-system-kernel - operating-system-bootloader - operating-system-base-packages - operating-system-users - operating-system-groups - operating-system-file-systems - operating-system-services - operating-system-loader-entries - operating-system-rc-conf-entries - operating-system-init-mode - operating-system-ready-marker - operating-system-root-authorized-keys - validate-operating-system - materialize-freebsd-source - operating-system-closure-spec - operating-system-install-spec - operating-system-image-spec - operating-system-installer-image-spec - installer-operating-system - materialize-operating-system - materialize-rootfs - install-operating-system - materialize-bhyve-image - materialize-installer-image - default-minimal-operating-system)) - -(define-record-type - (make-user-group name gid system?) - user-group? - (name user-group-name) - (gid user-group-gid) - (system? user-group-system?)) - -(define* (user-group #:key name gid (system? #t)) - (make-user-group name gid system?)) - -(define-record-type - (make-user-account name uid group supplementary-groups comment home shell system?) - user-account? - (name user-account-name) - (uid user-account-uid) - (group user-account-group) - (supplementary-groups user-account-supplementary-groups) - (comment user-account-comment) - (home user-account-home) - (shell user-account-shell) - (system? user-account-system?)) - -(define* (user-account #:key name uid group (supplementary-groups '()) - (comment "Fruix user") (home "/nonexistent") - (shell "/usr/sbin/nologin") (system? #t)) - (make-user-account name uid group supplementary-groups comment home shell system?)) - -(define-record-type - (make-file-system device mount-point type options needed-for-boot?) - file-system? - (device file-system-device) - (mount-point file-system-mount-point) - (type file-system-type) - (options file-system-options) - (needed-for-boot? file-system-needed-for-boot?)) - -(define* (file-system #:key device mount-point type (options "rw") - (needed-for-boot? #f)) - (make-file-system device mount-point type options needed-for-boot?)) - -(define-record-type - (make-operating-system host-name freebsd-base kernel bootloader base-packages users groups - file-systems services loader-entries rc-conf-entries - init-mode ready-marker root-authorized-keys) - operating-system? - (host-name operating-system-host-name) - (freebsd-base operating-system-freebsd-base) - (kernel operating-system-kernel) - (bootloader operating-system-bootloader) - (base-packages operating-system-base-packages) - (users operating-system-users) - (groups operating-system-groups) - (file-systems operating-system-file-systems) - (services operating-system-services) - (loader-entries operating-system-loader-entries) - (rc-conf-entries operating-system-rc-conf-entries) - (init-mode operating-system-init-mode) - (ready-marker operating-system-ready-marker) - (root-authorized-keys operating-system-root-authorized-keys)) - -(define* (operating-system #:key - (host-name "fruix-freebsd") - (freebsd-base %default-freebsd-base) - (kernel freebsd-kernel) - (bootloader freebsd-bootloader) - (base-packages %freebsd-system-packages) - (users (list (user-account #:name "root" - #:uid 0 - #:group "wheel" - #:comment "Charlie &" - #:home "/root" - #:shell "/bin/sh" - #:system? #t) - (user-account #:name "operator" - #:uid 1000 - #:group "operator" - #:supplementary-groups '("wheel") - #:comment "Fruix Operator" - #:home "/home/operator" - #:shell "/bin/sh" - #:system? #f))) - (groups (list (user-group #:name "wheel" #:gid 0 #:system? #t) - (user-group #:name "operator" #:gid 1000 #:system? #f))) - (file-systems (list (file-system #:device "/dev/ufs/fruix-root" - #:mount-point "/" - #:type "ufs" - #:options "rw" - #:needed-for-boot? #t) - (file-system #:device "devfs" - #:mount-point "/dev" - #:type "devfs" - #:options "rw" - #:needed-for-boot? #t) - (file-system #:device "tmpfs" - #:mount-point "/tmp" - #:type "tmpfs" - #:options "rw,size=64m" - #:needed-for-boot? #f))) - (services '(shepherd ready-marker)) - (loader-entries '(("autoboot_delay" . "1") - ("console" . "comconsole"))) - (rc-conf-entries '(("clear_tmp_enable" . "YES") - ("sendmail_enable" . "NONE") - ("sshd_enable" . "NO"))) - (init-mode 'freebsd-init+rc.d-shepherd) - (ready-marker "/var/lib/fruix/ready") - (root-authorized-keys '())) - (make-operating-system host-name freebsd-base kernel bootloader base-packages users groups - file-systems services loader-entries rc-conf-entries - init-mode ready-marker root-authorized-keys)) - -(define default-minimal-operating-system (operating-system)) - -(define (getenv* name default) - (or (getenv name) default)) - -(define (trim-trailing-newlines str) - (let loop ((len (string-length str))) - (if (and (> len 0) - (char=? (string-ref str (- len 1)) #\newline)) - (loop (- len 1)) - (substring str 0 len)))) - -(define (command-output program . args) - (let* ((port (apply open-pipe* OPEN_READ program args)) - (output (get-string-all port)) - (status (close-pipe port))) - (unless (zero? status) - (error (format #f "command failed: ~a ~s => ~a" program args status))) - (trim-trailing-newlines output))) - -(define (safe-command-output program . args) - (false-if-exception (apply command-output program args))) - -(define (write-file path content) - (mkdir-p (dirname path)) - (call-with-output-file path - (lambda (port) - (display content port)))) - -(define (string-hash text) - (let* ((tmp (string-append (getenv* "TMPDIR" "/tmp") "/fruix-system-hash.txt"))) - (write-file tmp text) - (command-output "sha256" "-q" tmp))) - -(define (file-hash path) - (command-output "sha256" "-q" path)) - -(define (host-freebsd-provenance) - (let ((src-git? (file-exists? "/usr/src/.git")) - (newvers "/usr/src/sys/conf/newvers.sh")) - `((freebsd-release . ,freebsd-release) - (freebsd-version-kru . ,(or (safe-command-output "freebsd-version" "-kru") "unknown")) - (uname . ,(or (safe-command-output "uname" "-a") "unknown")) - (usr-src-path . "/usr/src") - (usr-src-git-revision . ,(or (and src-git? - (safe-command-output "git" "-C" "/usr/src" "rev-parse" "HEAD")) - "absent")) - (usr-src-git-branch . ,(or (and src-git? - (safe-command-output "git" "-C" "/usr/src" "rev-parse" "--abbrev-ref" "HEAD")) - "absent")) - (usr-src-newvers-sha256 . ,(if (file-exists? newvers) - (file-hash newvers) - "absent"))))) - -(define (directory-entries path) - (sort (filter (lambda (entry) - (not (member entry '("." "..")))) - (scandir path)) - stringstring (stat:type st))))))) - -(define (install-plan-signature entry) - (match entry - (('file source target) - (string-append "file-target:" target "\n" (path-signature source))) - (('directory source target) - (string-append "directory-target:" target "\n" (path-signature source))) - (_ - (error (format #f "unsupported install plan entry: ~s" entry))))) - -(define native-freebsd-build-version "1") - -(define (freebsd-native-build-system? build-system) - (not (not (memq build-system '(freebsd-kernel-build-system freebsd-world-build-system))))) - -(define (build-plan-ref plan key default) - (match (assoc key plan) - ((_ . value) value) - (#f default))) - -(define (make-flag->pair flag) - (match (string-split flag #\=) - ((name value ...) (cons name (string-join value "="))) - ((name) (cons name "yes")) - (_ (error (format #f "invalid make flag: ~a" flag))))) - -(define (native-build-kernconf-path plan) - (or (build-plan-ref plan 'kernconf-path #f) - (string-append (build-plan-ref plan 'source-root "/usr/src") - "/sys/" - (build-plan-ref plan 'target-arch "amd64") - "/conf/" - (build-plan-ref plan 'kernconf "GENERIC")))) - -(define (native-build-source-tree-sha256 source-root) - (let* ((mtree-output (command-output "mtree" "-c" "-k" "type,link,size,mode,sha256digest" "-p" source-root)) - (stable-lines (filter (lambda (line) - (not (string-prefix? "#" line))) - (string-split mtree-output #\newline)))) - (string-hash (string-join stable-lines "\n")))) - -(define (native-build-common-manifest plan) - (let* ((source-root (build-plan-ref plan 'source-root "/usr/src")) - (target (build-plan-ref plan 'target "amd64")) - (target-arch (build-plan-ref plan 'target-arch "amd64")) - (kernconf (build-plan-ref plan 'kernconf "GENERIC")) - (make-flags (build-plan-ref plan 'make-flags '())) - (kernconf-path (native-build-kernconf-path plan))) - (unless (file-exists? source-root) - (error (format #f "native FreeBSD source root does not exist: ~a" source-root))) - (unless (file-exists? kernconf-path) - (error (format #f "native FreeBSD kernconf does not exist: ~a" kernconf-path))) - `((build-version . ,native-freebsd-build-version) - (source-root . ,source-root) - (source-tree-identity-mode . "mtree:type,link,size,mode,sha256digest") - (source-tree-sha256 . ,(or (build-plan-ref plan 'materialized-source-tree-sha256 #f) - (native-build-source-tree-sha256 source-root))) - (target . ,target) - (target-arch . ,target-arch) - (kernconf . ,kernconf) - (kernconf-path . ,kernconf-path) - (kernconf-sha256 . ,(file-hash kernconf-path)) - (make-flags . ,make-flags)))) - -(define (native-build-declared-base plan) - `((name . ,(build-plan-ref plan 'base-name "default")) - (version-label . ,(build-plan-ref plan 'base-version-label freebsd-release)) - (release . ,(build-plan-ref plan 'base-release freebsd-release)) - (branch . ,(build-plan-ref plan 'base-branch "unknown")))) - -(define (native-build-declared-source plan) - `((name . ,(build-plan-ref plan 'base-source-name "default")) - (kind . ,(build-plan-ref plan 'base-source-kind 'local-tree)) - (url . ,(build-plan-ref plan 'base-source-url #f)) - (path . ,(build-plan-ref plan 'base-source-path #f)) - (ref . ,(build-plan-ref plan 'base-source-ref #f)) - (commit . ,(build-plan-ref plan 'base-source-commit #f)) - (sha256 . ,(build-plan-ref plan 'base-source-sha256 #f)))) - -(define (native-build-materialized-source plan) - `((store-path . ,(build-plan-ref plan 'materialized-source-store #f)) - (source-root . ,(build-plan-ref plan 'source-root "/usr/src")) - (info-file . ,(build-plan-ref plan 'materialized-source-info-file #f)) - (tree-sha256 . ,(build-plan-ref plan 'materialized-source-tree-sha256 #f)) - (cache-path . ,(build-plan-ref plan 'materialized-source-cache-path #f)) - (effective-source . ((kind . ,(build-plan-ref plan 'effective-source-kind #f)) - (url . ,(build-plan-ref plan 'effective-source-url #f)) - (path . ,(build-plan-ref plan 'effective-source-path #f)) - (ref . ,(build-plan-ref plan 'effective-source-ref #f)) - (commit . ,(build-plan-ref plan 'effective-source-commit #f)) - (sha256 . ,(build-plan-ref plan 'effective-source-sha256 #f)))))) - -(define (native-build-manifest-string package input-paths) - (let* ((plan (freebsd-package-install-plan package)) - (common (native-build-common-manifest plan)) - (declared-base (native-build-declared-base plan)) - (declared-source (native-build-declared-source plan)) - (materialized-source (native-build-materialized-source plan)) - (keep-paths (build-plan-ref plan 'keep-paths '())) - (prune-paths (build-plan-ref plan 'prune-paths '()))) - (string-append - "name=" (freebsd-package-name package) "\n" - "version=" (freebsd-package-version package) "\n" - "build-system=" (symbol->string (freebsd-package-build-system package)) "\n" - "inputs=" (string-join input-paths ",") "\n" - "declared-base=\n" - (object->string declared-base) - "\ndeclared-source=\n" - (object->string declared-source) - "\nmaterialized-source=\n" - (object->string materialized-source) - "\nnative-build-common=\n" - (object->string common) - "\nkeep-paths=\n" - (object->string keep-paths) - "\nprune-paths=\n" - (object->string prune-paths)))) - -(define (copy-build-manifest-string package input-paths) - (string-append - "name=" (freebsd-package-name package) "\n" - "version=" (freebsd-package-version package) "\n" - "build-system=" (symbol->string (freebsd-package-build-system package)) "\n" - "inputs=" (string-join input-paths ",") "\n" - "install-plan-signature=\n" - (string-join (map install-plan-signature - (freebsd-package-install-plan package)) - "\n"))) - -(define (package-manifest-string package input-paths) - (if (freebsd-native-build-system? (freebsd-package-build-system package)) - (native-build-manifest-string package input-paths) - (copy-build-manifest-string package input-paths))) - -(define (copy-regular-file source destination) - (let ((mode (stat:perms (stat source)))) - (copy-file source destination) - (chmod destination mode))) - -(define (copy-node source destination) - (let ((kind (stat:type (lstat source)))) - (mkdir-p (dirname destination)) - (case kind - ((directory) - (mkdir-p destination) - (for-each (lambda (entry) - (copy-node (string-append source "/" entry) - (string-append destination "/" entry))) - (directory-entries source))) - ((symlink) - (symlink (readlink source) destination)) - (else - (copy-regular-file source destination))))) - -(define (materialize-plan-entry output-path entry) - (match entry - (('file source target) - (copy-node source (string-append output-path "/" target))) - (('directory source target) - (copy-node source (string-append output-path "/" target))) - (_ - (error (format #f "unsupported install plan entry: ~s" entry))))) - -(define (clear-file-flags path) - (false-if-exception (system* "chflags" "-R" "noschg,nouchg" path))) - -(define (delete-path-if-exists path) - (when (or (file-exists? path) (false-if-exception (readlink path))) - (clear-file-flags path) - (let ((kind (stat:type (lstat path)))) - (case kind - ((directory) (delete-file-recursively path)) - (else (delete-file path)))))) - -(define (stage-tree-into-output stage-root output-path) - (mkdir-p output-path) - (for-each (lambda (entry) - (copy-node (string-append stage-root "/" entry) - (string-append output-path "/" entry))) - (directory-entries stage-root))) - -(define (current-build-jobs) - (or (getenv "FRUIX_FREEBSD_BUILD_JOBS") - (safe-command-output "sysctl" "-n" "hw.ncpu") - "1")) - -(define (native-build-root common) - (string-append "/var/tmp/fruix-freebsd-native-build-" - (string-hash (object->string common)))) - -(define (native-make-arguments common _build-root) - (append - (list "-C" (assoc-ref common 'source-root) - (string-append "TARGET=" (assoc-ref common 'target)) - (string-append "TARGET_ARCH=" (assoc-ref common 'target-arch)) - (string-append "KERNCONF=" (assoc-ref common 'kernconf))) - (assoc-ref common 'make-flags))) - -(define* (make-command-string common build-root target #:key (parallel? #f) (destdir #f)) - (string-join - (append - (list "env" (string-append "MAKEOBJDIRPREFIX=" build-root "/obj") "make") - (if parallel? - (list (string-append "-j" (current-build-jobs))) - '()) - (native-make-arguments common build-root) - (if destdir - (list (string-append "DESTDIR=" destdir)) - '()) - (list target)) - " ")) - -(define (run-command/log log-file command) - (mkdir-p (dirname log-file)) - (let ((status (system* "sh" "-c" (string-append command " >" log-file " 2>&1")))) - (unless (zero? status) - (error (format #f "command failed; see ~a: ~a" log-file command))))) - -(define (ensure-native-build-root common build-root) - (mkdir-p build-root) - (mkdir-p (string-append build-root "/logs")) - (mkdir-p (string-append build-root "/stamps")) - (write-file (string-append build-root "/build-parameters.scm") - (object->string common))) - -(define (ensure-native-buildworld common build-root) - (let ((stamp (string-append build-root "/stamps/buildworld.done"))) - (ensure-native-build-root common build-root) - (unless (file-exists? stamp) - (run-command/log (string-append build-root "/logs/buildworld.log") - (make-command-string common build-root "buildworld" #:parallel? #t)) - (write-file stamp "ok\n")))) - -(define (ensure-native-buildkernel common build-root) - (let ((stamp (string-append build-root "/stamps/buildkernel-" (assoc-ref common 'kernconf) ".done"))) - (ensure-native-buildworld common build-root) - (unless (file-exists? stamp) - (run-command/log (string-append build-root "/logs/buildkernel-" (assoc-ref common 'kernconf) ".log") - (make-command-string common build-root "buildkernel" #:parallel? #t)) - (write-file stamp "ok\n")))) - -(define (prune-stage-paths stage-root paths) - (for-each (lambda (path) - (delete-path-if-exists (string-append stage-root "/" path))) - paths)) - -(define (select-stage-paths stage-root paths) - (let ((selected-root (string-append stage-root ".selected"))) - (delete-path-if-exists selected-root) - (mkdir-p selected-root) - (for-each (lambda (path) - (let ((source (string-append stage-root "/" path)) - (target (string-append selected-root "/" path))) - (unless (or (file-exists? source) - (false-if-exception (readlink source))) - (error (format #f "native stage path is missing: ~a" source))) - (copy-node source target))) - paths) - selected-root)) -(define (native-build-output-metadata package common build-root stage-root) - (let ((plan (freebsd-package-install-plan package))) - `((package . ,(freebsd-package-name package)) - (version . ,(freebsd-package-version package)) - (declared-base . ,(native-build-declared-base plan)) - (declared-source . ,(native-build-declared-source plan)) - (materialized-source . ,(native-build-materialized-source plan)) - (build-system . ,(freebsd-package-build-system package)) - (source-root . ,(assoc-ref common 'source-root)) - (source-tree-sha256 . ,(assoc-ref common 'source-tree-sha256)) - (target . ,(assoc-ref common 'target)) - (target-arch . ,(assoc-ref common 'target-arch)) - (kernconf . ,(assoc-ref common 'kernconf)) - (kernconf-path . ,(assoc-ref common 'kernconf-path)) - (kernconf-sha256 . ,(assoc-ref common 'kernconf-sha256)) - (make-flags . ,(assoc-ref common 'make-flags)) - (keep-paths . ,(build-plan-ref plan 'keep-paths '())) - (prune-paths . ,(build-plan-ref plan 'prune-paths '())) - (build-root . ,build-root) - (stage-root . ,stage-root) - (buildworld-log . ,(string-append build-root "/logs/buildworld.log")) - (buildkernel-log . ,(string-append build-root "/logs/buildkernel-" (assoc-ref common 'kernconf) ".log")) - (install-log . ,(string-append build-root "/logs/install-" (freebsd-package-name package) ".log"))))) - -(define (materialize-native-freebsd-package package input-paths manifest output-path) - (let* ((plan (freebsd-package-install-plan package)) - (common (native-build-common-manifest plan)) - (build-root (native-build-root common)) - (stage-root (string-append build-root "/stage-" (freebsd-package-name package) "-" (string-hash manifest))) - (install-log (string-append build-root "/logs/install-" (freebsd-package-name package) ".log")) - (final-stage-root - (case (freebsd-package-build-system package) - ((freebsd-world-build-system) - (ensure-native-buildworld common build-root) - (delete-path-if-exists stage-root) - (mkdir-p stage-root) - (run-command/log install-log - (string-append (make-command-string common build-root "installworld" #:destdir stage-root) - " && " - (make-command-string common build-root "distribution" #:destdir stage-root))) - (let* ((keep-paths (build-plan-ref plan 'keep-paths '())) - (selected-root (if (null? keep-paths) - stage-root - (select-stage-paths stage-root keep-paths)))) - (prune-stage-paths selected-root (build-plan-ref plan 'prune-paths '())) - selected-root)) - ((freebsd-kernel-build-system) - (ensure-native-buildkernel common build-root) - (delete-path-if-exists stage-root) - (mkdir-p stage-root) - (run-command/log install-log - (make-command-string common build-root "installkernel" #:destdir stage-root)) - stage-root) - (else - (error (format #f "unsupported native FreeBSD build system: ~a" - (freebsd-package-build-system package))))))) - (mkdir-p output-path) - (stage-tree-into-output final-stage-root output-path) - (write-file (string-append output-path "/.references") - (string-join input-paths "\n")) - (write-file (string-append output-path "/.fruix-package") manifest) - (write-file (string-append output-path "/.freebsd-native-build-info.scm") - (object->string (native-build-output-metadata package common build-root final-stage-root))))) - -(define (package-with-install-plan package install-plan) - (freebsd-package - #:name (freebsd-package-name package) - #:version (freebsd-package-version package) - #:build-system (freebsd-package-build-system package) - #:inputs (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-plan install-plan)) - -(define (plan-freebsd-source plan) - (freebsd-source #:name (build-plan-ref plan 'base-source-name "default") - #:kind (build-plan-ref plan 'base-source-kind 'local-tree) - #:url (build-plan-ref plan 'base-source-url #f) - #:path (build-plan-ref plan 'base-source-path #f) - #:ref (build-plan-ref plan 'base-source-ref #f) - #:commit (build-plan-ref plan 'base-source-commit #f) - #:sha256 (build-plan-ref plan 'base-source-sha256 #f))) - -(define (source-cache-key source) - (string-hash (object->string (freebsd-source-spec source)))) - -(define (materialize-freebsd-source/cached source store-dir source-cache) - (let* ((key (source-cache-key source)) - (cached (hash-ref source-cache key #f))) - (or cached - (let ((result (materialize-freebsd-source source #:store-dir store-dir))) - (hash-set! source-cache key result) - result)))) - -(define (plan-with-materialized-source plan source-result) - (let* ((effective (assoc-ref source-result 'effective-source)) - (overrides - `((source-root . ,(assoc-ref source-result 'source-root)) - (materialized-source-store . ,(assoc-ref source-result 'source-store-path)) - (materialized-source-info-file . ,(assoc-ref source-result 'source-info-file)) - (materialized-source-tree-sha256 . ,(assoc-ref source-result 'source-tree-sha256)) - (materialized-source-cache-path . ,(assoc-ref source-result 'cache-path)) - (effective-source-kind . ,(assoc-ref effective 'kind)) - (effective-source-url . ,(assoc-ref effective 'url)) - (effective-source-path . ,(assoc-ref effective 'path)) - (effective-source-ref . ,(assoc-ref effective 'ref)) - (effective-source-commit . ,(assoc-ref effective 'commit)) - (effective-source-sha256 . ,(assoc-ref effective 'sha256))))) - (append overrides plan))) - -(define* (materialize-freebsd-package package store-dir cache #:optional source-cache) - (let* ((source-cache (or source-cache (make-hash-table))) - (input-paths (map (lambda (input) - (materialize-freebsd-package input store-dir cache source-cache)) - (freebsd-package-inputs package))) - (prepared-package - (if (freebsd-native-build-package? package) - (let* ((source (plan-freebsd-source (freebsd-package-install-plan package))) - (source-result (materialize-freebsd-source/cached source store-dir source-cache)) - (plan (plan-with-materialized-source (freebsd-package-install-plan package) - source-result))) - (package-with-install-plan package plan)) - package)) - (effective-input-paths - (if (freebsd-native-build-package? package) - (cons (build-plan-ref (freebsd-package-install-plan prepared-package) - 'materialized-source-store - #f) - input-paths) - input-paths)) - (effective-input-paths (filter identity effective-input-paths)) - (manifest (package-manifest-string prepared-package effective-input-paths)) - (cache-key (string-hash manifest)) - (cached (hash-ref cache cache-key #f))) - (if cached - cached - (let* ((hash (string-hash manifest)) - (output-path (string-append store-dir "/" hash "-" - (freebsd-package-name prepared-package) - "-" - (freebsd-package-version prepared-package)))) - (unless (file-exists? output-path) - (case (freebsd-package-build-system prepared-package) - ((copy-build-system) - (mkdir-p output-path) - (for-each (lambda (entry) - (materialize-plan-entry output-path entry)) - (freebsd-package-install-plan prepared-package)) - (write-file (string-append output-path "/.references") - (string-join effective-input-paths "\n")) - (write-file (string-append output-path "/.fruix-package") manifest)) - ((freebsd-world-build-system freebsd-kernel-build-system) - (materialize-native-freebsd-package prepared-package effective-input-paths manifest output-path)) - (else - (error (format #f "unsupported package build system: ~a" - (freebsd-package-build-system prepared-package)))))) - (hash-set! cache cache-key output-path) - output-path)))) - -(define prefix-materializer-version "3") - -(define (string-replace-all str old new) - (let ((old-len (string-length old))) - (let loop ((start 0) (chunks '())) - (let ((index (string-contains str old start))) - (if index - (loop (+ index old-len) - (cons new - (cons (substring str start index) chunks))) - (apply string-append - (reverse (cons (substring str start) chunks)))))))) - -(define (rewrite-text-file path replacements) - (when (file-exists? path) - (let* ((mode (stat:perms (stat path))) - (original (call-with-input-file path get-string-all)) - (updated (fold (lambda (replacement text) - (string-replace-all text (car replacement) (cdr replacement))) - original - replacements))) - (unless (string=? original updated) - (write-file path updated) - (chmod path mode))))) - -(define (delete-file-if-exists path) - (when (file-exists? path) - (delete-file path))) - -(define (sanitize-materialized-prefix name output-path) - (cond - ((string=? name "fruix-guile-extra") - (rewrite-text-file - (string-append output-path "/share/guile/site/3.0/fibers/config.scm") - '(("((getenv \"FIBERS_BUILD_DIR\")\n => (lambda (builddir) (in-vicinity builddir \".libs\")))\n (else \"/tmp/guile-gnutls-freebsd-validate-install/lib/guile/3.0/extensions\"))" - . "((getenv \"FIBERS_BUILD_DIR\")\n => (lambda (builddir) (in-vicinity builddir \".libs\")))\n ((getenv \"GUILE_EXTENSIONS_PATH\"))\n (else \"/usr/local/lib/guile/3.0/extensions\"))"))) - (rewrite-text-file - (string-append output-path "/share/guile/site/3.0/gnutls.scm") - '(("\"/tmp/guile-gnutls-freebsd-validate-install/lib/guile/3.0/extensions\"" - . "(or (getenv \"GUILE_EXTENSIONS_PATH\") \"/usr/local/lib/guile/3.0/extensions\")"))) - (delete-file-if-exists (string-append output-path "/lib/guile/3.0/site-ccache/fibers/config.go")) - (delete-file-if-exists (string-append output-path "/lib/guile/3.0/site-ccache/gnutls.go"))) - ((string=? name "fruix-shepherd-runtime") - (rewrite-text-file - (string-append output-path "/share/guile/site/3.0/shepherd/config.scm") - '(("(define Prefix-dir \"/tmp/shepherd-freebsd-validate-install\")" - . "(define Prefix-dir \"/frx\")") - ("(define %localstatedir \"/tmp/shepherd-freebsd-validate-install/var\")" - . "(define %localstatedir \"/var\")") - ("(define %runstatedir \"/tmp/shepherd-freebsd-validate-install/var/run\")" - . "(define %runstatedir \"/var/run\")") - ("(define %sysconfdir \"/tmp/shepherd-freebsd-validate-install/etc\")" - . "(define %sysconfdir \"/etc\")") - ("(define %localedir \"/tmp/shepherd-freebsd-validate-install/share/locale\")" - . "(define %localedir \"/usr/share/locale\")") - ("(define %pkglibdir \"/tmp/shepherd-freebsd-validate-install/lib/shepherd\")" - . "(define %pkglibdir \"/usr/local/lib/shepherd\")"))) - (delete-file-if-exists (string-append output-path "/lib/guile/3.0/site-ccache/shepherd/config.go")))) - #t) - -(define (prefix-manifest-string source-path extra-files) - (string-append - "prefix-materializer-version=" prefix-materializer-version "\n" - "prefix-source=" source-path "\n" - (path-signature source-path) - (if (null? extra-files) - "" - (string-append - "\nextra-files=\n" - (string-join - (map (lambda (entry) - (string-append (cdr entry) "\n" (path-signature (car entry)))) - extra-files) - "\n"))))) - -(define (copy-extra-node source destination) - (let ((kind (stat:type (lstat source)))) - (mkdir-p (dirname destination)) - (case kind - ((symlink) - (unless (or (file-exists? destination) - (false-if-exception (readlink destination))) - (let ((target (readlink source))) - (symlink target destination) - (unless (string-prefix? "/" target) - (copy-extra-node (string-append (dirname source) "/" target) - (string-append (dirname destination) "/" target)))))) - (else - (unless (file-exists? destination) - (copy-node source destination)))))) - -(define* (materialize-prefix source-path name version store-dir #:key (extra-files '())) - (let* ((manifest (prefix-manifest-string source-path extra-files)) - (hash (string-hash manifest)) - (output-path (string-append store-dir "/" hash "-" name "-" version))) - (unless (file-exists? output-path) - (mkdir-p output-path) - (for-each (lambda (entry) - (copy-node (string-append source-path "/" entry) - (string-append output-path "/" entry))) - (directory-entries source-path)) - (for-each (lambda (entry) - (copy-extra-node (car entry) - (string-append output-path "/" (cdr entry)))) - extra-files) - (sanitize-materialized-prefix name output-path) - (write-file (string-append output-path "/.fruix-package") manifest)) - output-path)) - -(define (package-names packages) - (map freebsd-package-name packages)) - -(define (freebsd-source-spec source) - `((name . ,(freebsd-source-name source)) - (kind . ,(freebsd-source-kind source)) - (url . ,(freebsd-source-url source)) - (path . ,(freebsd-source-path source)) - (ref . ,(freebsd-source-ref source)) - (commit . ,(freebsd-source-commit source)) - (sha256 . ,(freebsd-source-sha256 source)))) - -(define (freebsd-base-spec base) - `((name . ,(freebsd-base-name base)) - (version-label . ,(freebsd-base-version-label base)) - (release . ,(freebsd-base-release base)) - (branch . ,(freebsd-base-branch base)) - (source-root . ,(freebsd-base-source-root base)) - (source . ,(freebsd-source-spec (freebsd-base-source base))) - (target . ,(freebsd-base-target base)) - (target-arch . ,(freebsd-base-target-arch base)) - (kernconf . ,(freebsd-base-kernconf base)) - (make-flags . ,(freebsd-base-make-flags base)))) - -(define freebsd-source-materializer-version "2") - -(define (string-downcase* value) - (list->string (map char-downcase (string->list value)))) - -(define (safe-name-fragment value) - (let* ((text (if (and (string? value) (not (string-null? value))) value "source")) - (chars (map (lambda (ch) - (if (or (char-alphabetic? ch) - (char-numeric? ch) - (memv ch '(#\- #\_ #\.))) - ch - #\-)) - (string->list text)))) - (list->string chars))) - -(define (freebsd-source-manifest source effective-source identity) - (string-append - "materializer-version=" freebsd-source-materializer-version "\n" - "declared-source=\n" - (object->string (freebsd-source-spec source)) - "\neffective-source=\n" - (object->string (freebsd-source-spec effective-source)) - "\nidentity=\n" - (object->string identity))) - -(define (copy-tree-contents source-root target-root) - (mkdir-p target-root) - (for-each (lambda (entry) - (copy-node (string-append source-root "/" entry) - (string-append target-root "/" entry))) - (directory-entries source-root))) - -(define (ensure-git-source-cache source cache-dir) - (let* ((url (freebsd-source-url source)) - (repo-dir (string-append cache-dir "/git/" - (string-hash (string-append "git:" url)) - ".git"))) - (mkdir-p (dirname repo-dir)) - (unless (file-exists? repo-dir) - (unless (zero? (system* "git" "init" "--quiet" "--bare" repo-dir)) - (error "failed to initialize git source cache" repo-dir)) - (unless (zero? (system* "git" "-C" repo-dir "remote" "add" "origin" url)) - (error "failed to add git source remote" url))) - (let ((current-url (safe-command-output "git" "-C" repo-dir "remote" "get-url" "origin"))) - (unless (and current-url (string=? current-url url)) - (unless (zero? (system* "git" "-C" repo-dir "remote" "set-url" "origin" url)) - (error "failed to update git source remote" url)))) - repo-dir)) - -(define (resolve-git-freebsd-source source cache-dir) - (let* ((selector (or (freebsd-source-commit source) - (freebsd-source-ref source) - (error "git freebsd source requires a ref or commit" source))) - (repo-dir (ensure-git-source-cache source cache-dir))) - (unless (zero? (system* "git" "-C" repo-dir "fetch" "--quiet" "--depth" "1" "origin" selector)) - (error "failed to fetch git freebsd source" selector)) - (let ((resolved-commit (command-output "git" "-C" repo-dir "rev-parse" "FETCH_HEAD"))) - `((cache-path . ,repo-dir) - (effective-source . ,(freebsd-source #:name (freebsd-source-name source) - #:kind 'git - #:url (freebsd-source-url source) - #:ref (freebsd-source-ref source) - #:commit resolved-commit - #:sha256 #f)) - (identity . ((resolved-commit . ,resolved-commit))) - (populate-tree . ,(lambda (tree-root) - (let ((archive-path (string-append (dirname tree-root) "/git-export.tar"))) - (unless (zero? (system* "git" "-C" repo-dir "archive" - "--format=tar" "-o" archive-path resolved-commit)) - (error "failed to archive git freebsd source" resolved-commit)) - (unless (zero? (system* "tar" "-xpf" archive-path "-C" tree-root)) - (error "failed to extract archived git freebsd source" archive-path)) - (delete-path-if-exists archive-path)))))))) - -(define (normalize-expected-sha256 source) - (let ((sha256 (freebsd-source-sha256 source))) - (and sha256 (string-downcase* sha256)))) - -(define (resolve-txz-freebsd-source source cache-dir) - (let* ((url (freebsd-source-url source)) - (expected-sha256 (or (normalize-expected-sha256 source) - (error "src-txz freebsd source requires sha256 for materialization" source))) - (archive-path (string-append cache-dir "/archives/" - (string-hash (string-append "txz:" url)) - "-src.txz"))) - (mkdir-p (dirname archive-path)) - (when (file-exists? archive-path) - (let ((actual (string-downcase* (file-hash archive-path)))) - (unless (string=? actual expected-sha256) - (delete-file archive-path)))) - (unless (file-exists? archive-path) - (unless (zero? (system* "fetch" "-q" "-o" archive-path url)) - (error "failed to download FreeBSD src.txz source" url))) - (let ((actual-sha256 (string-downcase* (file-hash archive-path)))) - (unless (string=? actual-sha256 expected-sha256) - (error "downloaded src.txz hash mismatch" url expected-sha256 actual-sha256)) - `((cache-path . ,archive-path) - (effective-source . ,(freebsd-source #:name (freebsd-source-name source) - #:kind 'src-txz - #:url url - #:path #f - #:ref #f - #:commit #f - #:sha256 actual-sha256)) - (identity . ((archive-sha256 . ,actual-sha256))) - (populate-tree . ,(lambda (tree-root) - (unless (zero? (system* "tar" "-xpf" archive-path "-C" tree-root)) - (error "failed to extract FreeBSD src.txz source" archive-path)))))))) - -(define (resolve-local-freebsd-source source) - (let* ((path (freebsd-source-path source)) - (tree-sha256 (native-build-source-tree-sha256 path))) - `((cache-path . #f) - (effective-source . ,(freebsd-source #:name (freebsd-source-name source) - #:kind 'local-tree - #:url #f - #:path path - #:ref #f - #:commit #f - #:sha256 tree-sha256)) - (identity . ((tree-sha256 . ,tree-sha256))) - (populate-tree . ,(lambda (tree-root) - (copy-tree-contents path tree-root)))))) - -(define (detect-materialized-source-relative-root tree-root) - (cond - ((file-exists? (string-append tree-root "/Makefile")) - "tree") - ((file-exists? (string-append tree-root "/usr/src/Makefile")) - "tree/usr/src") - (else - "tree"))) - -(define* (materialize-freebsd-source source #:key - (store-dir "/frx/store") - (cache-dir "/frx/var/cache/fruix/freebsd-source")) - (validate-freebsd-source source) - (let* ((resolution (case (freebsd-source-kind source) - ((local-tree) - (resolve-local-freebsd-source source)) - ((git) - (resolve-git-freebsd-source source cache-dir)) - ((src-txz) - (resolve-txz-freebsd-source source cache-dir)) - (else - (error "unsupported freebsd source kind" (freebsd-source-kind source))))) - (effective-source (assoc-ref resolution 'effective-source)) - (identity (assoc-ref resolution 'identity)) - (manifest (freebsd-source-manifest source effective-source identity)) - (hash (string-hash manifest)) - (output-path (string-append store-dir "/" hash "-freebsd-source-" - (safe-name-fragment (freebsd-source-name source)))) - (info-file (string-append output-path "/.freebsd-source-info.scm")) - (cache-path (assoc-ref resolution 'cache-path)) - (populate-tree (assoc-ref resolution 'populate-tree))) - (unless (file-exists? output-path) - (let* ((temp-output (string-append output-path ".tmp")) - (temp-tree-root (string-append temp-output "/tree"))) - (delete-path-if-exists temp-output) - (mkdir-p temp-tree-root) - (populate-tree temp-tree-root) - (let* ((relative-root (detect-materialized-source-relative-root temp-tree-root)) - (source-root (string-append output-path "/" relative-root)) - (temp-source-root (string-append temp-output "/" relative-root)) - (tree-sha256 (native-build-source-tree-sha256 temp-source-root))) - (write-file (string-append temp-output "/.references") "") - (write-file (string-append temp-output "/.fruix-source") manifest) - (write-file (string-append temp-output "/.freebsd-source-info.scm") - (object->string - `((materializer-version . ,freebsd-source-materializer-version) - (declared-source . ,(freebsd-source-spec source)) - (effective-source . ,(freebsd-source-spec effective-source)) - (identity . ,identity) - (source-store . ,output-path) - (source-root . ,source-root) - (source-tree-sha256 . ,tree-sha256) - (cache-path . ,cache-path))))) - (rename-file temp-output output-path))) - (call-with-input-file info-file - (lambda (port) - (let* ((info (read port)) - (effective (assoc-ref info 'effective-source))) - `((source-store-path . ,output-path) - (source-root . ,(assoc-ref info 'source-root)) - (source-info-file . ,info-file) - (source-tree-sha256 . ,(assoc-ref info 'source-tree-sha256)) - (cache-path . ,(assoc-ref info 'cache-path)) - (effective-source . ,effective) - (effective-commit . ,(assoc-ref effective 'commit)) - (effective-sha256 . ,(assoc-ref effective 'sha256)))))))) - -(define (duplicate-elements values) - (let loop ((rest values) (seen '()) (duplicates '())) - (match rest - (() (reverse duplicates)) - ((head . tail) - (if (member head seen) - (loop tail seen (if (member head duplicates) duplicates (cons head duplicates))) - (loop tail (cons head seen) duplicates)))))) - -(define (non-empty-string? value) - (and (string? value) - (not (string-null? value)))) - -(define (validate-freebsd-source source) - (unless (freebsd-source? source) - (error "freebsd base source must be a record")) - (let ((kind (freebsd-source-kind source))) - (unless (member kind '(local-tree git src-txz)) - (error "unsupported freebsd source kind" kind)) - (case kind - ((local-tree) - (unless (non-empty-string? (freebsd-source-path source)) - (error "local-tree freebsd source must declare a path" source))) - ((git) - (unless (non-empty-string? (freebsd-source-url source)) - (error "git freebsd source must declare a URL" source)) - (unless (or (non-empty-string? (freebsd-source-ref source)) - (non-empty-string? (freebsd-source-commit source))) - (error "git freebsd source must declare a ref or commit" source))) - ((src-txz) - (unless (non-empty-string? (freebsd-source-url source)) - (error "src-txz freebsd source must declare a URL" source)) - (unless (non-empty-string? (freebsd-source-sha256 source)) - (error "src-txz freebsd source must declare a sha256" source))))) - #t) - -(define (validate-operating-system os) - (let* ((host-name (operating-system-host-name os)) - (base (operating-system-freebsd-base os)) - (users (operating-system-users os)) - (groups (operating-system-groups os)) - (file-systems (operating-system-file-systems os)) - (user-names (map user-account-name users)) - (group-names (map user-group-name groups)) - (mount-points (map file-system-mount-point file-systems)) - (init-mode (operating-system-init-mode os))) - (when (string-null? host-name) - (error "operating-system host-name must not be empty")) - (unless (freebsd-base? base) - (error "operating-system freebsd-base must be a record")) - (validate-freebsd-source (freebsd-base-source base)) - (let ((dups (duplicate-elements user-names))) - (unless (null? dups) - (error "duplicate user names in operating-system" dups))) - (let ((dups (duplicate-elements group-names))) - (unless (null? dups) - (error "duplicate group names in operating-system" dups))) - (unless (member "/" mount-points) - (error "operating-system must declare a root file-system")) - (unless (member "root" user-names) - (error "operating-system must declare a root user")) - (unless (member "wheel" group-names) - (error "operating-system must declare a wheel group")) - (unless (member init-mode '(freebsd-init+rc.d-shepherd shepherd-pid1)) - (error "unsupported operating-system init-mode" init-mode)) - #t)) - -(define (pid1-init-mode? os) - (eq? (operating-system-init-mode os) 'shepherd-pid1)) - -(define (effective-loader-entries os) - (append (if (pid1-init-mode? os) - '(("init_exec" . "/run/current-system/boot/fruix-pid1")) - '()) - (operating-system-loader-entries os))) - -(define (render-loader-conf os) - (string-append - (string-join (map (lambda (entry) - (format #f "~a=\"~a\"" (car entry) (cdr entry))) - (effective-loader-entries os)) - "\n") - "\n")) - -(define (rc-conf-entry-value os key) - (let ((entry (assoc key (operating-system-rc-conf-entries os)))) - (and entry (cdr entry)))) - -(define (sshd-enabled? os) - (let ((value (rc-conf-entry-value os "sshd_enable"))) - (and value - (member (string-upcase value) '("YES" "TRUE" "1"))))) - -(define (render-rc.conf os) - (let* ((entries (append `(("hostname" . ,(operating-system-host-name os)) - ("fruix_activate_enable" . "YES") - ("fruix_shepherd_enable" . "YES")) - (operating-system-rc-conf-entries os)))) - (string-append - (string-join (map (lambda (entry) - (format #f "~a=\"~a\"" (car entry) (cdr entry))) - entries) - "\n") - "\n"))) - -(define (group-name->gid groups name) - (let ((group (find (lambda (item) - (string=? (user-group-name item) name)) - groups))) - (and group (user-group-gid group)))) - -(define (render-passwd os) - (let ((groups (operating-system-groups os))) - (string-append - (string-join - (map (lambda (account) - (format #f "~a:*:~a:~a:~a:~a:~a" - (user-account-name account) - (user-account-uid account) - (or (group-name->gid groups (user-account-group account)) - (error "unknown primary group" (user-account-group account))) - (user-account-comment account) - (user-account-home account) - (user-account-shell account))) - (operating-system-users os)) - "\n") - "\n"))) - -(define (render-master-passwd os) - (let ((groups (operating-system-groups os))) - (string-append - (string-join - (map (lambda (account) - (format #f "~a:*:~a:~a::0:0:~a:~a:~a" - (user-account-name account) - (user-account-uid account) - (or (group-name->gid groups (user-account-group account)) - (error "unknown primary group" (user-account-group account))) - (user-account-comment account) - (user-account-home account) - (user-account-shell account))) - (operating-system-users os)) - "\n") - "\n"))) - -(define (render-group os) - (let ((users (operating-system-users os))) - (string-append - (string-join - (map (lambda (group) - (let ((members (filter-map (lambda (account) - (and (member (user-group-name group) - (user-account-supplementary-groups account)) - (user-account-name account))) - users))) - (format #f "~a:*:~a:~a" - (user-group-name group) - (user-group-gid group) - (string-join members ",")))) - (operating-system-groups os)) - "\n") - "\n"))) - -(define (fstab-fsck-fields fs) - (if (string=? (file-system-type fs) "ufs") - (if (string=? (file-system-mount-point fs) "/") - '(1 1) - '(2 2)) - '(0 0))) - -(define (render-fstab os) - (string-append - (string-join - (map (lambda (fs) - (let ((checks (fstab-fsck-fields fs))) - (format #f "~a\t~a\t~a\t~a\t~a\t~a" - (file-system-device fs) - (file-system-mount-point fs) - (file-system-type fs) - (file-system-options fs) - (first checks) - (second checks)))) - (operating-system-file-systems os)) - "\n") - "\n")) - -(define (render-hosts os) - (string-append - "127.0.0.1\tlocalhost " (operating-system-host-name os) "\n" - "::1\tlocalhost\n")) - -(define (render-shells os) - (let ((shells (delete-duplicates (map user-account-shell (operating-system-users os))))) - (string-append (string-join shells "\n") "\n"))) - -(define (render-motd os) - (string-append "Welcome to Fruix on FreeBSD (" (operating-system-host-name os) ")\n")) - -(define (render-login-conf) - (string-append - "default:\\\n" - "\t:path=/sbin /bin /usr/sbin /usr/bin /usr/local/sbin /usr/local/bin:\\\n" - "\t:umask=022:\\\n" - "\t:charset=UTF-8:\\\n" - "\t:lang=C.UTF-8:\n" - "daemon:\\\n" - "\t:path=/sbin /bin /usr/sbin /usr/bin /usr/local/sbin /usr/local/bin:\\\n" - "\t:tc=default:\n" - "root:\\\n" - "\t:ignorenologin:\\\n" - "\t:tc=default:\n")) - -(define (render-ttys) - (string-append - "console\tnone\tunknown\toff secure\n" - "ttyu0\tnone\tvt100\toff secure\n" - "xc0\tnone\txterm\toff secure\n")) - -(define (render-root-authorized-keys os) - (if (null? (operating-system-root-authorized-keys os)) - "" - (string-append - (string-join (operating-system-root-authorized-keys os) "\n") - "\n"))) - -(define (render-sshd-config os) - (string-append - "Port 22\n" - "PermitRootLogin yes\n" - "PasswordAuthentication no\n" - "KbdInteractiveAuthentication no\n" - "ChallengeResponseAuthentication no\n" - "UsePAM no\n" - "PubkeyAuthentication yes\n" - "AuthorizedKeysFile .ssh/authorized_keys\n" - "PidFile /var/run/sshd.pid\n" - "UseDNS no\n")) - -(define* (render-activation-script os #:key guile-store guile-extra-store shepherd-store) - (let* ((users (operating-system-users os)) - (groups (operating-system-groups os)) - (home-setup - (string-join - (map (lambda (account) - (let ((name (user-account-name account)) - (uid (user-account-uid account)) - (gid (or (group-name->gid groups (user-account-group account)) - (error "unknown primary group" (user-account-group account)))) - (home (user-account-home account)) - (system? (user-account-system? account))) - (string-append - "mkdir -p " home "\n" - (if (or (string=? name "root") system?) - "" - (format #f "if [ -x /usr/sbin/chown ]; then /usr/sbin/chown ~a:~a ~a 2>/dev/null || true; fi\n" - uid gid home))))) - users) - "")) - (refresh-db-input-files - (string-join - (map (lambda (entry) - (match entry - ((name mode) - (string-append - "if [ -f /run/current-system/etc/" name " ]; then rm -f /etc/" name "; cp /run/current-system/etc/" name " /etc/" name "; chmod " mode " /etc/" name "; fi\n")))) - '(("passwd" "0644") - ("master.passwd" "0600") - ("group" "0644") - ("login.conf" "0644"))) - "")) - (ssh-section - (string-append - "mkdir -p /var/empty /etc/ssh /root/.ssh\n" - "chmod 700 /root/.ssh\n" - (if (null? (operating-system-root-authorized-keys os)) - "" - "if [ -f /run/current-system/root/.ssh/authorized_keys ]; then cp /run/current-system/root/.ssh/authorized_keys /root/.ssh/authorized_keys; chmod 600 /root/.ssh/authorized_keys; fi\n") - (if (sshd-enabled? os) - "if [ -x /usr/bin/ssh-keygen ]; then /usr/bin/ssh-keygen -A; fi\n" - "")))) - (string-append - "#!/bin/sh\n" - "set -eu\n" - "logfile=/var/log/fruix-activate.log\n" - "mkdir -p /var/cron /var/db /var/lib/fruix /var/log /var/run /root /home /tmp\n" - ": >> \"$logfile\"\n" - "trap 'status=$?; echo \"fruix-activate:exit status=$status\" >> \"$logfile\"' EXIT\n" - "echo \"fruix-activate:start\" >> \"$logfile\"\n" - "chmod 1777 /tmp\n" - refresh-db-input-files - "if [ -x /usr/bin/cap_mkdb ] && [ -f /etc/login.conf ]; then\n" - " if /usr/bin/cap_mkdb /etc/login.conf; then echo \"fruix-activate:cap_mkdb=ok\" >> \"$logfile\"; else echo \"fruix-activate:cap_mkdb=failed\" >> \"$logfile\"; fi\n" - "fi\n" - "if [ -x /usr/sbin/pwd_mkdb ] && [ -f /etc/master.passwd ]; then\n" - " if /usr/sbin/pwd_mkdb -p /etc/master.passwd; then echo \"fruix-activate:pwd_mkdb=ok\" >> \"$logfile\"; else echo \"fruix-activate:pwd_mkdb=failed\" >> \"$logfile\"; fi\n" - "fi\n" - home-setup - ssh-section - "echo \"fruix-activate:done\" >> \"$logfile\"\n"))) - -(define (pid1-mount-commands os) - (string-join - (filter-map (lambda (fs) - (and (not (string=? "/" (file-system-mount-point fs))) - (string-append - "mkdir -p '" (file-system-mount-point fs) "'\n" - "/sbin/mount -t '" (file-system-type fs) - "' -o '" (file-system-options fs) - "' '" (file-system-device fs) - "' '" (file-system-mount-point fs) - "' >/dev/null 2>&1 || true\n"))) - (operating-system-file-systems os)) - "")) - -(define (render-pid1-script os shepherd-store guile-store guile-extra-store) - (let ((ld-library-path (string-append guile-extra-store "/lib:" - guile-store "/lib:/usr/local/lib")) - (guile-system-path - (string-append guile-store "/share/guile/3.0:" - guile-store "/share/guile/site/3.0:" - guile-store "/share/guile/site:" - guile-store "/share/guile")) - (guile-load-path (string-append shepherd-store "/share/guile/site/3.0:" - guile-extra-store "/share/guile/site/3.0")) - (guile-system-compiled-path - (string-append guile-store "/lib/guile/3.0/ccache:" - guile-store "/lib/guile/3.0/site-ccache")) - (guile-load-compiled-path - (string-append shepherd-store "/lib/guile/3.0/site-ccache:" - guile-extra-store "/lib/guile/3.0/site-ccache")) - (guile-system-extensions-path (string-append guile-store "/lib/guile/3.0/extensions")) - (guile-extensions-path (string-append guile-extra-store "/lib/guile/3.0/extensions"))) - (string-append - "#!/bin/sh\n" - "set -eu\n" - "PATH=/sbin:/bin:/usr/sbin:/usr/bin:/usr/local/sbin:/usr/local/bin\n" - "/sbin/mount -u -o rw / >/dev/null 2>&1 || true\n" - (pid1-mount-commands os) - "/bin/hostname '" (operating-system-host-name os) "' >/dev/null 2>&1 || true\n" - "/run/current-system/activate\n" - "export GUILE_AUTO_COMPILE=0\n" - "export LANG='C.UTF-8'\n" - "export LC_ALL='C.UTF-8'\n" - "export LD_LIBRARY_PATH='" ld-library-path "'\n" - "export GUILE_SYSTEM_PATH='" guile-system-path "'\n" - "export GUILE_LOAD_PATH='" guile-load-path "'\n" - "export GUILE_SYSTEM_COMPILED_PATH='" guile-system-compiled-path "'\n" - "export GUILE_LOAD_COMPILED_PATH='" guile-load-compiled-path "'\n" - "export GUILE_SYSTEM_EXTENSIONS_PATH='" guile-system-extensions-path "'\n" - "export GUILE_EXTENSIONS_PATH='" guile-extensions-path "'\n" - "exec " guile-store "/bin/guile --no-auto-compile " shepherd-store "/bin/shepherd -I -s /var/run/shepherd.sock -c /run/current-system/shepherd/init.scm --pid=/var/run/shepherd.pid -l /var/log/shepherd.log\n"))) - -(define (render-shepherd-config os) - (let* ((ready-marker (operating-system-ready-marker os)) - (pid1? (pid1-init-mode? os)) - (start-sshd? (and pid1? (or (sshd-enabled? os) - (member 'sshd (operating-system-services os))))) - (ready-requirements (if start-sshd? - "'(fruix-logger sshd)" - "'(fruix-logger)")) - (pid1-helpers - (if pid1? - (string-append - "(define (run-command program . args)\n" - " (let ((status (apply system* program args)))\n" - " (unless (zero? status)\n" - " (error \"command failed\" (cons program args) status))\n" - " #t))\n\n" - "(define* (freebsd-rc-service provision script-name\n" - " #:key\n" - " (requirement '())\n" - " (documentation\n" - " \"Manage a FreeBSD rc.d service through 'service'.\"))\n" - " (service provision\n" - " #:documentation documentation\n" - " #:requirement requirement\n" - " #:start (lambda _\n" - " (run-command \"/usr/sbin/service\" script-name \"onestart\")\n" - " #t)\n" - " #:stop (lambda _\n" - " (run-command \"/usr/sbin/service\" script-name \"onestop\")\n" - " #f)\n" - " #:respawn? #f))\n\n") - "")) - (pid1-services - (if pid1? - (string-append - (if start-sshd? - " (freebsd-rc-service '(netif) \"netif\"\n" - "") - (if start-sshd? - " #:requirement '(fruix-logger)\n" - "") - (if start-sshd? - " #:documentation \"Bring up FreeBSD networking from rc.conf.\")\n" - "") - (if start-sshd? - " (freebsd-rc-service '(sshd) \"sshd\"\n" - "") - (if start-sshd? - " #:requirement '(netif)\n" - "") - (if start-sshd? - " #:documentation \"Start OpenSSH under Shepherd PID 1.\")\n" - "")) - ""))) - (string-append - "(use-modules (shepherd service)\n" - " (ice-9 ftw)\n" - " (ice-9 popen))\n\n" - "(define ready-marker \"" ready-marker "\")\n\n" - "(define (mkdir-p* dir)\n" - " (unless (or (string=? dir \"\")\n" - " (string=? dir \"/\")\n" - " (file-exists? dir))\n" - " (mkdir-p* (dirname dir))\n" - " (mkdir dir)))\n\n" - "(define (ensure-parent-directory file)\n" - " (mkdir-p* (dirname file)))\n\n" - pid1-helpers - "(register-services\n" - " (list\n" - " (service '(fruix-logger)\n" - " #:documentation \"Append a boot trace line for Fruix.\"\n" - " #:start (lambda _\n" - " (ensure-parent-directory \"/var/log/fruix-shepherd.log\")\n" - " (let ((port (open-file \"/var/log/fruix-shepherd.log\" \"a\")))\n" - " (display \"fruix-shepherd-started\\n\" port)\n" - " (close-port port))\n" - " #t)\n" - " #:stop (lambda _ #f)\n" - " #:respawn? #f)\n" - pid1-services - " (service '(fruix-ready)\n" - " #:documentation \"Write the Fruix ready marker.\"\n" - " #:requirement " ready-requirements "\n" - " #:start (lambda _\n" - " (ensure-parent-directory ready-marker)\n" - " (call-with-output-file ready-marker\n" - " (lambda (port) (display \"ready\" port)))\n" - " #t)\n" - " #:stop (lambda _ #f)\n" - " #:respawn? #f)))\n\n" - "(start-service (lookup-service 'fruix-ready))\n"))) - -(define (render-activation-rc-script) - (string-append - "#!/bin/sh\n" - "# PROVIDE: fruix_activate\n" - "# REQUIRE: FILESYSTEMS\n" - "# BEFORE: LOGIN sshd fruix_shepherd\n" - "# KEYWORD: shutdown\n\n" - ". /etc/rc.subr\n\n" - "name=fruix_activate\n" - "rcvar=fruix_activate_enable\n" - ": ${fruix_activate_enable:=YES}\n" - "start_cmd=fruix_activate_start\n" - "stop_cmd=:\n\n" - "fruix_activate_start()\n" - "{\n" - " /run/current-system/activate\n" - "}\n\n" - "load_rc_config $name\n" - "run_rc_command \"$1\"\n")) - -(define (render-rc-script shepherd-store guile-store guile-extra-store) - (let ((ld-library-path (string-append guile-extra-store "/lib:" - guile-store "/lib:/usr/local/lib")) - (guile-system-path - (string-append guile-store "/share/guile/3.0:" - guile-store "/share/guile/site/3.0:" - guile-store "/share/guile/site:" - guile-store "/share/guile")) - (guile-load-path (string-append shepherd-store "/share/guile/site/3.0:" - guile-extra-store "/share/guile/site/3.0")) - (guile-system-compiled-path - (string-append guile-store "/lib/guile/3.0/ccache:" - guile-store "/lib/guile/3.0/site-ccache")) - (guile-load-compiled-path - (string-append shepherd-store "/lib/guile/3.0/site-ccache:" - guile-extra-store "/lib/guile/3.0/site-ccache")) - (guile-system-extensions-path (string-append guile-store "/lib/guile/3.0/extensions")) - (guile-extensions-path (string-append guile-extra-store "/lib/guile/3.0/extensions"))) - (string-append - "#!/bin/sh\n" - "# PROVIDE: fruix_shepherd\n" - "# REQUIRE: FILESYSTEMS fruix_activate\n" - "# BEFORE: LOGIN\n" - "# KEYWORD: shutdown\n\n" - ". /etc/rc.subr\n\n" - "name=fruix_shepherd\n" - "rcvar=fruix_shepherd_enable\n" - ": ${fruix_shepherd_enable:=YES}\n" - "pidfile=/var/run/shepherd.pid\n" - "socket=/var/run/shepherd.sock\n" - "config=/run/current-system/shepherd/init.scm\n" - "logfile=/var/log/shepherd.log\n" - "command=" shepherd-store "/bin/shepherd\n" - "start_cmd=fruix_shepherd_start\n" - "stop_cmd=fruix_shepherd_stop\n" - "status_cmd=fruix_shepherd_status\n\n" - "fruix_shepherd_start()\n" - "{\n" - " /usr/sbin/daemon -c -f -p \"$pidfile\" -o /var/log/shepherd-bootstrap.out /usr/bin/env \\\n" - " LANG='C.UTF-8' LC_ALL='C.UTF-8' \\\n" - " LD_LIBRARY_PATH='" ld-library-path "' \\\n" - " GUILE_SYSTEM_PATH='" guile-system-path "' \\\n" - " GUILE_LOAD_PATH='" guile-load-path "' \\\n" - " GUILE_SYSTEM_COMPILED_PATH='" guile-system-compiled-path "' \\\n" - " GUILE_LOAD_COMPILED_PATH='" guile-load-compiled-path "' \\\n" - " GUILE_SYSTEM_EXTENSIONS_PATH='" guile-system-extensions-path "' \\\n" - " GUILE_EXTENSIONS_PATH='" guile-extensions-path "' \\\n" - " " guile-store "/bin/guile --no-auto-compile " shepherd-store "/bin/shepherd -I -s \"$socket\" -c \"$config\" -l \"$logfile\"\n" - " for _try in 1 2 3 4 5 6 7 8 9 10; do\n" - " [ -f \"$pidfile\" ] && [ -S \"$socket\" ] && return 0\n" - " sleep 1\n" - " done\n" - " return 1\n" - "}\n\n" - "fruix_shepherd_stop()\n" - "{\n" - " env LANG='C.UTF-8' LC_ALL='C.UTF-8' \\\n" - " LD_LIBRARY_PATH='" ld-library-path "' \\\n" - " GUILE_SYSTEM_PATH='" guile-system-path "' \\\n" - " GUILE_LOAD_PATH='" guile-load-path "' \\\n" - " GUILE_SYSTEM_COMPILED_PATH='" guile-system-compiled-path "' \\\n" - " GUILE_LOAD_COMPILED_PATH='" guile-load-compiled-path "' \\\n" - " GUILE_SYSTEM_EXTENSIONS_PATH='" guile-system-extensions-path "' \\\n" - " GUILE_EXTENSIONS_PATH='" guile-extensions-path "' \\\n" - " " guile-store "/bin/guile --no-auto-compile " shepherd-store "/bin/herd -s \"$socket\" stop root >/dev/null 2>&1 || true\n" - " for _try in 1 2 3 4 5 6 7 8 9 10; do\n" - " [ ! -f \"$pidfile\" ] && return 0\n" - " sleep 1\n" - " done\n" - " kill \"$(cat \"$pidfile\")\" >/dev/null 2>&1 || true\n" - " rm -f \"$pidfile\"\n" - " return 0\n" - "}\n\n" - "fruix_shepherd_status()\n" - "{\n" - " [ -f \"$pidfile\" ] && kill -0 \"$(cat \"$pidfile\")\" >/dev/null 2>&1\n" - "}\n\n" - "load_rc_config $name\n" - "run_rc_command \"$1\"\n"))) - -(define (operating-system-generated-file-names os) - (append - '("boot/loader.conf" - "etc/rc.conf" - "etc/fstab" - "etc/hosts" - "etc/passwd" - "etc/master.passwd" - "etc/group" - "etc/login.conf" - "etc/shells" - "etc/motd" - "etc/ttys" - "metadata/freebsd-base.scm" - "metadata/host-base-provenance.scm" - "metadata/store-layout.scm" - "activate" - "shepherd/init.scm") - (if (pid1-init-mode? os) - '("boot/fruix-pid1") - '()) - (if (sshd-enabled? os) - '("etc/ssh/sshd_config") - '()) - (if (null? (operating-system-root-authorized-keys os)) - '() - '("root/.ssh/authorized_keys")))) - -(define* (operating-system-generated-files os #:key guile-store guile-extra-store shepherd-store) - (append - `(("boot/loader.conf" . ,(render-loader-conf os)) - ("etc/rc.conf" . ,(render-rc.conf os)) - ("etc/fstab" . ,(render-fstab os)) - ("etc/hosts" . ,(render-hosts os)) - ("etc/passwd" . ,(render-passwd os)) - ("etc/master.passwd" . ,(render-master-passwd os)) - ("etc/group" . ,(render-group os)) - ("etc/login.conf" . ,(render-login-conf)) - ("etc/shells" . ,(render-shells os)) - ("etc/motd" . ,(render-motd os)) - ("etc/ttys" . ,(render-ttys)) - ("activate" . ,(render-activation-script os - #:guile-store guile-store - #:guile-extra-store guile-extra-store - #:shepherd-store shepherd-store)) - ("shepherd/init.scm" . ,(render-shepherd-config os))) - (if (pid1-init-mode? os) - `(("boot/fruix-pid1" . ,(render-pid1-script os shepherd-store guile-store guile-extra-store))) - '()) - (if (sshd-enabled? os) - `(("etc/ssh/sshd_config" . ,(render-sshd-config os))) - '()) - (if (null? (operating-system-root-authorized-keys os)) - '() - `(("root/.ssh/authorized_keys" . ,(render-root-authorized-keys os)))))) - -(define (operating-system-closure-spec os) - (validate-operating-system os) - `((host-name . ,(operating-system-host-name os)) - (freebsd-base . ,(freebsd-base-spec (operating-system-freebsd-base os))) - (kernel-package . ,(freebsd-package-name (operating-system-kernel os))) - (bootloader-package . ,(freebsd-package-name (operating-system-bootloader os))) - (base-package-count . ,(length (operating-system-base-packages os))) - (base-packages . ,(package-names (operating-system-base-packages os))) - (user-count . ,(length (operating-system-users os))) - (users . ,(map user-account-name (operating-system-users os))) - (group-count . ,(length (operating-system-groups os))) - (groups . ,(map user-group-name (operating-system-groups os))) - (file-system-count . ,(length (operating-system-file-systems os))) - (file-systems . ,(map (lambda (fs) - `((device . ,(file-system-device fs)) - (mount-point . ,(file-system-mount-point fs)) - (type . ,(file-system-type fs)) - (options . ,(file-system-options fs)) - (needed-for-boot? . ,(file-system-needed-for-boot? fs)))) - (operating-system-file-systems os))) - (services . ,(operating-system-services os)) - (generated-files . ,(operating-system-generated-file-names os)) - (init-mode . ,(operating-system-init-mode os)) - (ready-marker . ,(operating-system-ready-marker os)))) - -(define (same-file-contents? a b) - (zero? (system* "cmp" "-s" a b))) - -(define (merge-output-into-tree output-path tree-root) - (define (walk relative) - (let ((source (if (string-null? relative) - output-path - (string-append output-path "/" relative)))) - (for-each - (lambda (entry) - (unless (or (member entry '(".references" ".fruix-package")) - (string-prefix? "." entry)) - (let* ((entry-relative (if (string-null? relative) - entry - (string-append relative "/" entry))) - (source-entry (string-append output-path "/" entry-relative)) - (target-entry (string-append tree-root "/" entry-relative)) - (st (lstat source-entry))) - (if (eq? 'directory (stat:type st)) - (begin - (mkdir-p target-entry) - (walk entry-relative)) - (begin - (mkdir-p (dirname target-entry)) - (if (file-exists? target-entry) - (let ((existing (false-if-exception (readlink target-entry)))) - (unless (or (and existing - (string=? existing source-entry)) - (and existing - (file-exists? existing) - (same-file-contents? existing source-entry))) - (error (format #f "tree collision for ~a" target-entry)))) - (symlink source-entry target-entry))))))) - (directory-entries source)))) - (mkdir-p tree-root) - (walk "")) - -(define (hash-table-values table) - (hash-fold (lambda (_ value result) - (cons value result)) - '() - table)) - -(define (freebsd-source-materialization-spec result) - `((source-store-path . ,(assoc-ref result 'source-store-path)) - (source-root . ,(assoc-ref result 'source-root)) - (source-info-file . ,(assoc-ref result 'source-info-file)) - (source-tree-sha256 . ,(assoc-ref result 'source-tree-sha256)) - (cache-path . ,(assoc-ref result 'cache-path)) - (effective-source . ,(assoc-ref result 'effective-source)))) - -(define* (materialize-operating-system os - #:key - (store-dir "/frx/store") - (guile-prefix "/tmp/guile-freebsd-validate-install") - (guile-extra-prefix "/tmp/guile-gnutls-freebsd-validate-install") - (shepherd-prefix "/tmp/shepherd-freebsd-validate-install")) - (validate-operating-system os) - (let* ((cache (make-hash-table)) - (source-cache (make-hash-table)) - (kernel-package (operating-system-kernel os)) - (bootloader-package (operating-system-bootloader os)) - (base-packages (operating-system-base-packages os)) - (kernel-store (materialize-freebsd-package kernel-package store-dir cache source-cache)) - (bootloader-store (materialize-freebsd-package bootloader-package store-dir cache source-cache)) - (base-package-stores (map (lambda (package) - (materialize-freebsd-package package store-dir cache source-cache)) - base-packages)) - (base-package-pairs (map cons base-packages base-package-stores)) - (store-classification - (append (list (cons kernel-package kernel-store) - (cons bootloader-package bootloader-store)) - base-package-pairs)) - (guile-runtime-extra-files - '(("/usr/local/lib/libgc-threaded.so.1" . "lib/libgc-threaded.so.1") - ("/usr/local/lib/libffi.so.8" . "lib/libffi.so.8") - ("/usr/local/lib/libintl.so.8" . "lib/libintl.so.8") - ("/usr/local/lib/libunistring.so.5" . "lib/libunistring.so.5") - ("/usr/local/lib/libiconv.so.2" . "lib/libiconv.so.2") - ("/usr/local/lib/libgmp.so.10" . "lib/libgmp.so.10"))) - (guile-extra-runtime-files - '(("/usr/local/lib/libevent-2.1.so.7" . "lib/libevent-2.1.so.7") - ("/usr/local/lib/libgnutls.so.30" . "lib/libgnutls.so.30") - ("/usr/local/lib/libp11-kit.so.0" . "lib/libp11-kit.so.0") - ("/usr/local/lib/libidn2.so.0" . "lib/libidn2.so.0") - ("/usr/local/lib/libtasn1.so.6" . "lib/libtasn1.so.6") - ("/usr/local/lib/libhogweed.so.6" . "lib/libhogweed.so.6") - ("/usr/local/lib/libnettle.so.8" . "lib/libnettle.so.8"))) - (guile-store (materialize-prefix guile-prefix "fruix-guile-runtime" "3.0" store-dir - #:extra-files guile-runtime-extra-files)) - (guile-extra-store (materialize-prefix guile-extra-prefix "fruix-guile-extra" "3.0" store-dir - #:extra-files (append guile-runtime-extra-files - guile-extra-runtime-files))) - (shepherd-store (materialize-prefix shepherd-prefix "fruix-shepherd-runtime" "1.0.9" store-dir)) - (host-base-stores - (delete-duplicates - (map cdr - (filter (lambda (entry) - (freebsd-host-staged-package? (car entry))) - store-classification)))) - (native-base-stores - (delete-duplicates - (map cdr - (filter (lambda (entry) - (freebsd-native-build-package? (car entry))) - store-classification)))) - (fruix-runtime-stores (list guile-store guile-extra-store shepherd-store)) - (source-materializations - (delete-duplicates (hash-table-values source-cache))) - (materialized-source-stores - (delete-duplicates (map (lambda (result) - (assoc-ref result 'source-store-path)) - source-materializations))) - (metadata-files - `(("metadata/freebsd-base.scm" - . ,(object->string (freebsd-base-spec (operating-system-freebsd-base os)))) - ("metadata/freebsd-source.scm" - . ,(object->string (freebsd-source-spec (freebsd-base-source (operating-system-freebsd-base os))))) - ("metadata/freebsd-source-materializations.scm" - . ,(object->string (map freebsd-source-materialization-spec source-materializations))) - ("metadata/host-base-provenance.scm" - . ,(object->string (host-freebsd-provenance))) - ("metadata/store-layout.scm" - . ,(object->string - `((freebsd-base . ,(freebsd-base-spec (operating-system-freebsd-base os))) - (freebsd-source . ,(freebsd-source-spec (freebsd-base-source (operating-system-freebsd-base os)))) - (materialized-source-store-count . ,(length materialized-source-stores)) - (materialized-source-stores . ,materialized-source-stores) - (host-base-store-count . ,(length host-base-stores)) - (host-base-stores . ,host-base-stores) - (native-base-store-count . ,(length native-base-stores)) - (native-base-stores . ,native-base-stores) - (fruix-runtime-store-count . ,(length fruix-runtime-stores)) - (fruix-runtime-stores . ,fruix-runtime-stores) - (host-base-replacement-order . ,%freebsd-host-staged-replacement-order) - (init-mode . ,(operating-system-init-mode os))))))) - (generated-files (append (operating-system-generated-files os - #:guile-store guile-store - #:guile-extra-store guile-extra-store - #:shepherd-store shepherd-store) - metadata-files - `(("usr/local/etc/rc.d/fruix-activate" - . ,(render-activation-rc-script)) - ("usr/local/etc/rc.d/fruix-shepherd" - . ,(render-rc-script shepherd-store guile-store guile-extra-store))))) - (references (delete-duplicates (append materialized-source-stores host-base-stores native-base-stores fruix-runtime-stores))) - (manifest (string-append - "closure-spec=\n" - (object->string (operating-system-closure-spec os)) - "generated-files=\n" - (string-join (map (lambda (entry) - (string-append (car entry) "\n" (cdr entry))) - generated-files) - "\n") - "\nreferences=\n" - (string-join references "\n"))) - (hash (string-hash manifest)) - (closure-path (string-append store-dir "/" hash "-fruix-system-" - (operating-system-host-name os)))) - (unless (file-exists? closure-path) - (mkdir-p closure-path) - (mkdir-p (string-append closure-path "/boot/kernel")) - (symlink (string-append kernel-store "/boot/kernel/kernel") - (string-append closure-path "/boot/kernel/kernel")) - (symlink (string-append kernel-store "/boot/kernel/linker.hints") - (string-append closure-path "/boot/kernel/linker.hints")) - (for-each - (lambda (entry) - (let ((name (car entry))) - (symlink (string-append bootloader-store "/boot/" name) - (string-append closure-path "/boot/" name)))) - '(("loader") ("loader.efi") ("device.hints") ("defaults") ("lua"))) - (mkdir-p (string-append closure-path "/profile")) - (for-each (lambda (output) - (merge-output-into-tree output (string-append closure-path "/profile"))) - base-package-stores) - (for-each - (lambda (entry) - (write-file (string-append closure-path "/" (car entry)) (cdr entry))) - generated-files) - (chmod (string-append closure-path "/activate") #o555) - (when (file-exists? (string-append closure-path "/etc/master.passwd")) - (chmod (string-append closure-path "/etc/master.passwd") #o600)) - (chmod (string-append closure-path "/usr/local/etc/rc.d/fruix-activate") #o555) - (chmod (string-append closure-path "/usr/local/etc/rc.d/fruix-shepherd") #o555) - (when (file-exists? (string-append closure-path "/boot/fruix-pid1")) - (chmod (string-append closure-path "/boot/fruix-pid1") #o555)) - (write-file (string-append closure-path "/parameters.scm") - (object->string (operating-system-closure-spec os))) - (write-file (string-append closure-path "/.references") - (string-join references "\n")) - (write-file (string-append closure-path "/.fruix-package") manifest)) - `((closure-path . ,closure-path) - (kernel-store . ,kernel-store) - (bootloader-store . ,bootloader-store) - (guile-store . ,guile-store) - (guile-extra-store . ,guile-extra-store) - (shepherd-store . ,shepherd-store) - (base-package-stores . ,base-package-stores) - (host-base-stores . ,host-base-stores) - (native-base-stores . ,native-base-stores) - (fruix-runtime-stores . ,fruix-runtime-stores) - (freebsd-base-file . ,(string-append closure-path "/metadata/freebsd-base.scm")) - (freebsd-source-file . ,(string-append closure-path "/metadata/freebsd-source.scm")) - (freebsd-source-materializations-file . ,(string-append closure-path "/metadata/freebsd-source-materializations.scm")) - (materialized-source-stores . ,materialized-source-stores) - (host-base-provenance-file . ,(string-append closure-path "/metadata/host-base-provenance.scm")) - (store-layout-file . ,(string-append closure-path "/metadata/store-layout.scm")) - (generated-files . ,(map car generated-files)) - (references . ,references)))) - -(define (symlink-force target link-name) - (when (or (file-exists? link-name) (false-if-exception (readlink link-name))) - (delete-file link-name)) - (mkdir-p (dirname link-name)) - (symlink target link-name)) - -(define (populate-rootfs-from-closure os rootfs closure-path) - (when (file-exists? rootfs) - (delete-file-recursively rootfs)) - (mkdir-p rootfs) - (for-each (lambda (dir) - (mkdir-p (string-append rootfs dir))) - '("/run" "/boot" "/etc" "/etc/ssh" "/usr" "/usr/share" "/usr/local" "/usr/local/etc" - "/usr/local/etc/rc.d" "/var" "/var/cron" "/var/db" "/var/lib" "/var/lib/fruix" - "/var/log" "/var/run" "/tmp" "/dev" "/root" "/home")) - (chmod (string-append rootfs "/tmp") #o1777) - (symlink-force closure-path (string-append rootfs "/run/current-system")) - (symlink-force "/run/current-system/activate" (string-append rootfs "/activate")) - (for-each (lambda (dir) - (symlink-force (string-append "/run/current-system/profile/" dir) - (string-append rootfs "/" dir))) - '("bin" "sbin" "lib" "libexec")) - (for-each (lambda (dir) - (symlink-force (string-append "/run/current-system/profile/usr/" dir) - (string-append rootfs "/usr/" dir))) - '("bin" "lib" "sbin" "libexec")) - (when (file-exists? (string-append closure-path "/profile/usr/share/locale")) - (symlink-force "/run/current-system/profile/usr/share/locale" - (string-append rootfs "/usr/share/locale"))) - (for-each (lambda (path) - (symlink-force (string-append "/run/current-system/profile/etc/" path) - (string-append rootfs "/etc/" path))) - '("rc" "rc.subr" "rc.shutdown" "rc.d" "defaults" - "devd.conf" "network.subr" "newsyslog.conf" "syslog.conf")) - (for-each (lambda (path) - (symlink-force (string-append "/run/current-system/etc/" path) - (string-append rootfs "/etc/" path))) - '("rc.conf" "fstab" "hosts" "shells" "motd" "ttys")) - (for-each (lambda (path) - (copy-regular-file (string-append closure-path "/etc/" path) - (string-append rootfs "/etc/" path))) - '("passwd" "master.passwd" "group" "login.conf")) - (when (file-exists? (string-append closure-path "/etc/ssh/sshd_config")) - (symlink-force "/run/current-system/etc/ssh/sshd_config" - (string-append rootfs "/etc/ssh/sshd_config"))) - (for-each (lambda (path) - (symlink-force (string-append "/run/current-system/boot/" path) - (string-append rootfs "/boot/" path))) - '("kernel" "loader" "loader.efi" "device.hints" "defaults" "lua" "loader.conf")) - (symlink-force "/run/current-system/usr/local/etc/rc.d/fruix-activate" - (string-append rootfs "/usr/local/etc/rc.d/fruix-activate")) - (symlink-force "/run/current-system/usr/local/etc/rc.d/fruix-shepherd" - (string-append rootfs "/usr/local/etc/rc.d/fruix-shepherd")) - `((rootfs . ,rootfs) - (closure-path . ,closure-path) - (ready-marker . ,(operating-system-ready-marker os)) - (rc-script . ,(string-append closure-path "/usr/local/etc/rc.d/fruix-shepherd")))) - -(define* (materialize-rootfs os rootfs - #:key - (store-dir "/frx/store") - (guile-prefix "/tmp/guile-freebsd-validate-install") - (guile-extra-prefix "/tmp/guile-gnutls-freebsd-validate-install") - (shepherd-prefix "/tmp/shepherd-freebsd-validate-install")) - (let* ((closure (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 closure 'closure-path))) - (populate-rootfs-from-closure os rootfs closure-path))) - -(define (assoc-remove keys entries) - (filter (lambda (entry) - (not (member (car entry) keys))) - entries)) - -(define (ensure-installer-groups groups) - (append groups - (filter (lambda (group) - (not (any (lambda (existing) - (string=? (user-group-name existing) - (user-group-name group))) - groups))) - (list (user-group #:name "sshd" #:gid 22 #:system? #t) - (user-group #:name "_dhcp" #:gid 65 #:system? #t))))) - -(define (ensure-installer-users users) - (append users - (filter (lambda (user) - (not (any (lambda (existing) - (string=? (user-account-name existing) - (user-account-name user))) - users))) - (list (user-account #:name "sshd" - #:uid 22 - #:group "sshd" - #:comment "Secure Shell Daemon" - #:home "/var/empty" - #:shell "/usr/sbin/nologin" - #:system? #t) - (user-account #:name "_dhcp" - #:uid 65 - #:group "_dhcp" - #:comment "dhcp programs" - #:home "/var/empty" - #:shell "/usr/sbin/nologin" - #:system? #t))))) - -(define* (installer-operating-system os - #:key - (host-name (string-append (operating-system-host-name os) - "-installer")) - (root-partition-label "fruix-installer-root") - (ready-marker "/var/lib/fruix/installer/ready")) - (operating-system - #:host-name host-name - #:freebsd-base (operating-system-freebsd-base os) - #:kernel (operating-system-kernel os) - #:bootloader (operating-system-bootloader os) - #:base-packages (operating-system-base-packages os) - #:users (ensure-installer-users (operating-system-users os)) - #:groups (ensure-installer-groups (operating-system-groups os)) - #:file-systems (list (file-system #:device (string-append "/dev/gpt/" root-partition-label) - #:mount-point "/" - #:type "ufs" - #:options "rw" - #:needed-for-boot? #t) - (file-system #:device "devfs" - #:mount-point "/dev" - #:type "devfs" - #:options "rw" - #:needed-for-boot? #t) - (file-system #:device "tmpfs" - #:mount-point "/tmp" - #:type "tmpfs" - #:options "rw,size=64m")) - #:services '(shepherd ready-marker sshd) - #:loader-entries (operating-system-loader-entries os) - #:rc-conf-entries (append (assoc-remove '("sshd_enable" "fruix_installer_enable") - (operating-system-rc-conf-entries os)) - '(("sshd_enable" . "YES") - ("fruix_installer_enable" . "YES"))) - #:init-mode 'freebsd-init+rc.d-shepherd - #:ready-marker ready-marker - #:root-authorized-keys (operating-system-root-authorized-keys os))) - -(define* (operating-system-install-spec os - #:key - target - (target-kind 'raw-file) - (boot-mode 'uefi) - (partition-scheme 'gpt) - (efi-size "64m") - (root-size #f) - (disk-capacity #f) - (efi-partition-label "efiboot") - (root-partition-label "fruix-root") - (serial-console "comconsole")) - `((host-name . ,(operating-system-host-name os)) - (freebsd-base . ,(freebsd-base-spec (operating-system-freebsd-base os))) - (install-mode . non-interactive) - (target . ,target) - (target-kind . ,target-kind) - (boot-mode . ,boot-mode) - (partition-scheme . ,partition-scheme) - (efi-size . ,efi-size) - (root-size . ,root-size) - (disk-capacity . ,disk-capacity) - (efi-partition-label . ,efi-partition-label) - (root-partition-label . ,root-partition-label) - (serial-console . ,serial-console) - (init-mode . ,(operating-system-init-mode os)))) - -(define* (operating-system-image-spec os - #:key - (boot-mode 'uefi) - (image-format 'raw) - (partition-scheme 'gpt) - (efi-size "64m") - (root-size "256m") - (disk-capacity #f) - (efi-partition-label "efiboot") - (root-partition-label "fruix-root") - (serial-console "comconsole")) - `((host-name . ,(operating-system-host-name os)) - (freebsd-base . ,(freebsd-base-spec (operating-system-freebsd-base os))) - (boot-mode . ,boot-mode) - (image-format . ,image-format) - (partition-scheme . ,partition-scheme) - (efi-size . ,efi-size) - (root-size . ,root-size) - (disk-capacity . ,disk-capacity) - (efi-partition-label . ,efi-partition-label) - (root-partition-label . ,root-partition-label) - (serial-console . ,serial-console) - (init-mode . ,(operating-system-init-mode os)))) - -(define* (operating-system-installer-image-spec os - #:key - (install-target-device "/dev/vtbd1") - (installer-host-name (string-append (operating-system-host-name os) - "-installer")) - (efi-size "64m") - (root-size "10g") - (disk-capacity #f) - (installer-efi-partition-label "efiboot") - (installer-root-partition-label "fruix-installer-root") - (target-efi-partition-label "efiboot") - (target-root-partition-label "fruix-root") - (serial-console "comconsole")) - (let* ((installer-os (installer-operating-system os - #:host-name installer-host-name - #:root-partition-label installer-root-partition-label)) - (target-install-spec (operating-system-install-spec os - #:target install-target-device - #:target-kind 'block-device - #:efi-size efi-size - #:root-size #f - #:disk-capacity #f - #:efi-partition-label target-efi-partition-label - #:root-partition-label target-root-partition-label - #:serial-console serial-console))) - `((installer-host-name . ,installer-host-name) - (install-target-device . ,install-target-device) - (installer-root-partition-label . ,installer-root-partition-label) - (installer-image . ,(operating-system-image-spec installer-os - #:efi-size efi-size - #:root-size root-size - #:disk-capacity disk-capacity - #:efi-partition-label installer-efi-partition-label - #:root-partition-label installer-root-partition-label - #:serial-console serial-console)) - (target-install . ,target-install-spec)))) - -(define (path-basename path) - (let ((parts (filter (lambda (part) (not (string-null? part))) - (string-split path #\/)))) - (if (null? parts) - path - (last parts)))) - -(define (read-lines path) - (if (file-exists? path) - (filter (lambda (line) (not (string-null? line))) - (string-split (call-with-input-file path get-string-all) #\newline)) - '())) - -(define (run-command . args) - (let ((status (apply system* args))) - (unless (zero? status) - (error "command failed" args status)) - #t)) - -(define (store-reference-closure roots) - (let ((seen (make-hash-table)) - (result '())) - (define (visit item) - (unless (hash-ref seen item #f) - (hash-set! seen item #t) - (set! result (cons item result)) - (for-each visit (read-lines (string-append item "/.references"))))) - (for-each visit roots) - (reverse result))) - -(define (copy-store-items-into-rootfs rootfs store-dir items) - (let ((store-root (string-append rootfs store-dir))) - (mkdir-p store-root) - (for-each (lambda (item) - (copy-node item (string-append store-root "/" (path-basename item)))) - items))) - -(define (copy-rootfs-for-image source-rootfs image-rootfs) - (when (file-exists? image-rootfs) - (delete-file-recursively image-rootfs)) - (copy-node source-rootfs image-rootfs)) - -(define (mktemp-directory pattern) - (command-output "mktemp" "-d" pattern)) - -(define image-builder-version "2") -(define install-builder-version "1") -(define installer-image-builder-version "1") - -(define (operating-system-install-metadata-object install-spec closure-path store-items) - `((install-version . ,install-builder-version) - (install-spec . ,install-spec) - (closure-path . ,closure-path) - (store-item-count . ,(length store-items)) - (store-items . ,store-items))) - -(define (render-installer-run-script store-dir plan-directory) - (let ((target-rootfs (string-append plan-directory "/target-rootfs")) - (store-items-file (string-append plan-directory "/store-items")) - (install-metadata-source (string-append plan-directory "/install.scm")) - (target-loader-efi (string-append plan-directory "/loader.efi")) - (state-file (string-append plan-directory "/state")) - (log-file "/var/log/fruix-installer.log") - (target-device-file (string-append plan-directory "/target-device")) - (efi-size-file (string-append plan-directory "/efi-size")) - (efi-label-file (string-append plan-directory "/efi-partition-label")) - (root-label-file (string-append plan-directory "/root-partition-label"))) - (string-append - "#!/bin/sh\n" - "set -eu\n" - "PATH=/sbin:/bin:/usr/sbin:/usr/bin:/usr/local/sbin:/usr/local/bin\n" - "umask 022\n" - "target_rootfs='" target-rootfs "'\n" - "store_items_file='" store-items-file "'\n" - "install_metadata_source='" install-metadata-source "'\n" - "target_loader_efi='" target-loader-efi "'\n" - "state_file='" state-file "'\n" - "log_file='" log-file "'\n" - "target_device=$(cat '" target-device-file "')\n" - "efi_size=$(cat '" efi-size-file "')\n" - "efi_partition_label=$(cat '" efi-label-file "')\n" - "root_partition_label=$(cat '" root-label-file "')\n" - "esp_device=\"${target_device}p1\"\n" - "root_device=\"${target_device}p2\"\n" - "mnt_root=/var/run/fruix-installer/target-root\n" - "mnt_esp=/var/run/fruix-installer/target-esp\n" - "write_state()\n" - "{\n" - " mkdir -p \"$(dirname \"$state_file\")\"\n" - " printf '%s\\n' \"$1\" >\"$state_file\"\n" - "}\n" - "cleanup()\n" - "{\n" - " umount \"$mnt_esp\" >/dev/null 2>&1 || true\n" - " umount \"$mnt_root\" >/dev/null 2>&1 || true\n" - "}\n" - "cleanup_and_record()\n" - "{\n" - " status=\"$1\"\n" - " if [ \"$status\" -ne 0 ]; then\n" - " echo \"fruix-installer:failed status=$status\"\n" - " write_state failed\n" - " fi\n" - " cleanup\n" - "}\n" - "trap 'status=$?; cleanup_and_record \"$status\"' EXIT\n" - "trap 'exit 1' INT TERM\n" - "mkdir -p \"$(dirname \"$log_file\")\" /var/run/fruix-installer\n" - "exec >>\"$log_file\" 2>&1\n" - "echo 'fruix-installer:start'\n" - "write_state starting\n" - "[ -e \"$target_device\" ] || { echo \"fruix-installer:error missing target device $target_device\"; exit 1; }\n" - "gpart destroy -F \"$target_device\" >/dev/null 2>&1 || true\n" - "gpart create -s gpt \"$target_device\"\n" - "gpart add -a 1m -s \"$efi_size\" -t efi -l \"$efi_partition_label\" \"$target_device\"\n" - "gpart add -a 1m -t freebsd-ufs -l \"$root_partition_label\" \"$target_device\"\n" - "newfs_msdos -L EFISYS \"$esp_device\"\n" - "newfs -U -L \"$root_partition_label\" \"$root_device\"\n" - "mkdir -p \"$mnt_root\" \"$mnt_esp\"\n" - "mount -t ufs \"$root_device\" \"$mnt_root\"\n" - "mount -t msdosfs \"$esp_device\" \"$mnt_esp\"\n" - "write_state copying-rootfs\n" - "(cd \"$target_rootfs\" && pax -rw -pe . \"$mnt_root\")\n" - "mkdir -p \"$mnt_root" store-dir "\"\n" - "write_state copying-store\n" - "while IFS= read -r item_base || [ -n \"$item_base\" ]; do\n" - " [ -n \"$item_base\" ] || continue\n" - " (cd '" store-dir "' && pax -rw -pe \"$item_base\" \"$mnt_root" store-dir "\")\n" - "done <\"$store_items_file\"\n" - "mkdir -p \"$mnt_root/var/lib/fruix\" \"$mnt_esp/EFI/BOOT\"\n" - "cp \"$target_loader_efi\" \"$mnt_esp/EFI/BOOT/BOOTX64.EFI\"\n" - "cp \"$install_metadata_source\" \"$mnt_root/var/lib/fruix/install.scm\"\n" - "sync\n" - "echo 'fruix-installer:done'\n" - "write_state done\n"))) - -(define (render-installer-rc-script plan-directory) - (string-append - "#!/bin/sh\n" - "# PROVIDE: fruix_installer\n" - "# REQUIRE: NETWORKING sshd fruix_shepherd\n" - "# KEYWORD: shutdown\n\n" - ". /etc/rc.subr\n\n" - "name=fruix_installer\n" - "rcvar=fruix_installer_enable\n" - ": ${fruix_installer_enable:=YES}\n" - "pidfile=/var/run/fruix-installer.pid\n" - "command=/usr/sbin/daemon\n" - "command_args='-c -f -p /var/run/fruix-installer.pid -o /var/log/fruix-installer-bootstrap.out /usr/local/libexec/fruix-installer-run'\n" - "start_cmd=fruix_installer_start\n" - "stop_cmd=fruix_installer_stop\n" - "status_cmd=fruix_installer_status\n\n" - "fruix_installer_start()\n" - "{\n" - " mkdir -p '" plan-directory "' /var/run\n" - " $command $command_args\n" - "}\n\n" - "fruix_installer_stop()\n" - "{\n" - " [ -f \"$pidfile\" ] && kill \"$(cat \"$pidfile\")\" >/dev/null 2>&1 || true\n" - " rm -f \"$pidfile\"\n" - " return 0\n" - "}\n\n" - "fruix_installer_status()\n" - "{\n" - " [ -f '" plan-directory "/state' ]\n" - "}\n\n" - "load_rc_config $name\n" - "run_rc_command \"$1\"\n")) - -(define (resize-gpt-image image disk-capacity) - (when disk-capacity - (run-command "truncate" "-s" disk-capacity image) - (let ((md (command-output "mdconfig" "-a" "-t" "vnode" "-f" image))) - (dynamic-wind - (lambda () #t) - (lambda () - (run-command "gpart" "recover" (string-append "/dev/" md))) - (lambda () - (run-command "mdconfig" "-d" "-u" (string-drop md 2))))))) - -(define* (install-operating-system os - #:key - target - (store-dir "/frx/store") - (guile-prefix "/tmp/guile-freebsd-validate-install") - (guile-extra-prefix "/tmp/guile-gnutls-freebsd-validate-install") - (shepherd-prefix "/tmp/shepherd-freebsd-validate-install") - (efi-size "64m") - (root-size #f) - (disk-capacity #f) - (efi-partition-label "efiboot") - (root-partition-label "fruix-root") - (serial-console "comconsole")) - (unless (and (string? target) (not (string-null? target))) - (error "install target must be a non-empty path" target)) - (let* ((closure (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 closure 'closure-path)) - (store-items (store-reference-closure (list closure-path))) - (target-kind (if (string-prefix? "/dev/" target) - 'block-device - 'raw-file)) - (install-spec (operating-system-install-spec os - #:target target - #:target-kind target-kind - #:efi-size efi-size - #:root-size root-size - #:disk-capacity disk-capacity - #:efi-partition-label efi-partition-label - #:root-partition-label root-partition-label - #:serial-console serial-console)) - (build-root (mktemp-directory "/tmp/fruix-system-install.XXXXXX")) - (rootfs (string-append build-root "/rootfs")) - (mnt-root (string-append build-root "/mnt-root")) - (mnt-esp (string-append build-root "/mnt-esp")) - (install-metadata-relative-path "/var/lib/fruix/install.scm") - (target-device #f) - (target-md #f) - (esp-device #f) - (root-device #f) - (root-mounted? #f) - (esp-mounted? #f)) - (dynamic-wind - (lambda () #t) - (lambda () - (populate-rootfs-from-closure os rootfs closure-path) - (mkdir-p mnt-root) - (mkdir-p mnt-esp) - (case target-kind - ((raw-file) - (unless disk-capacity - (error "raw-file install target requires --disk-capacity" target)) - (mkdir-p (dirname target)) - (delete-path-if-exists target) - (run-command "truncate" "-s" disk-capacity target) - (let ((md (command-output "mdconfig" "-a" "-t" "vnode" "-f" target))) - (set! target-md md) - (set! target-device (string-append "/dev/" md)))) - ((block-device) - (set! target-device target))) - (system* "sh" "-c" - (string-append "gpart destroy -F " target-device " >/dev/null 2>&1")) - (run-command "gpart" "create" "-s" "gpt" target-device) - (run-command "gpart" "add" "-a" "1m" "-s" efi-size - "-t" "efi" "-l" efi-partition-label target-device) - (if root-size - (run-command "gpart" "add" "-a" "1m" "-s" root-size - "-t" "freebsd-ufs" "-l" root-partition-label target-device) - (run-command "gpart" "add" "-a" "1m" - "-t" "freebsd-ufs" "-l" root-partition-label target-device)) - (set! esp-device (string-append target-device "p1")) - (set! root-device (string-append target-device "p2")) - (run-command "newfs_msdos" "-L" "EFISYS" esp-device) - (run-command "newfs" "-U" "-L" root-partition-label root-device) - (run-command "mount" "-t" "ufs" root-device mnt-root) - (set! root-mounted? #t) - (run-command "mount" "-t" "msdosfs" esp-device mnt-esp) - (set! esp-mounted? #t) - (copy-tree-contents rootfs mnt-root) - (copy-store-items-into-rootfs mnt-root store-dir store-items) - (mkdir-p (string-append mnt-esp "/EFI/BOOT")) - (copy-regular-file (string-append closure-path "/boot/loader.efi") - (string-append mnt-esp "/EFI/BOOT/BOOTX64.EFI")) - (let ((install-metadata-file (string-append mnt-root install-metadata-relative-path))) - (write-file install-metadata-file - (object->string - (operating-system-install-metadata-object install-spec closure-path store-items))) - (chmod install-metadata-file #o644)) - (run-command "sync") - `((target . ,target) - (target-kind . ,target-kind) - (target-device . ,target-device) - (esp-device . ,esp-device) - (root-device . ,root-device) - (install-spec . ,install-spec) - (install-metadata-path . ,install-metadata-relative-path) - (closure-path . ,closure-path) - (host-base-stores . ,(assoc-ref closure 'host-base-stores)) - (native-base-stores . ,(assoc-ref closure 'native-base-stores)) - (fruix-runtime-stores . ,(assoc-ref closure 'fruix-runtime-stores)) - (freebsd-base-file . ,(assoc-ref closure 'freebsd-base-file)) - (freebsd-source-file . ,(assoc-ref closure 'freebsd-source-file)) - (freebsd-source-materializations-file . ,(assoc-ref closure 'freebsd-source-materializations-file)) - (materialized-source-stores . ,(assoc-ref closure 'materialized-source-stores)) - (host-base-provenance-file . ,(assoc-ref closure 'host-base-provenance-file)) - (store-layout-file . ,(assoc-ref closure 'store-layout-file)) - (store-items . ,store-items))) - (lambda () - (when esp-mounted? - (system* "umount" mnt-esp) - (set! esp-mounted? #f)) - (when root-mounted? - (system* "umount" mnt-root) - (set! root-mounted? #f)) - (when target-md - (system* "mdconfig" "-d" "-u" (string-drop target-md 2)) - (set! target-md #f)) - (when (file-exists? build-root) - (delete-file-recursively build-root)))))) - -(define* (materialize-bhyve-image os - #:key - (store-dir "/frx/store") - (guile-prefix "/tmp/guile-freebsd-validate-install") - (guile-extra-prefix "/tmp/guile-gnutls-freebsd-validate-install") - (shepherd-prefix "/tmp/shepherd-freebsd-validate-install") - (efi-size "64m") - (root-size "256m") - (disk-capacity #f) - (efi-partition-label "efiboot") - (root-partition-label "fruix-root") - (serial-console "comconsole")) - (let* ((closure (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 closure 'closure-path)) - (image-spec (operating-system-image-spec os - #:efi-size efi-size - #:root-size root-size - #:disk-capacity disk-capacity - #:efi-partition-label efi-partition-label - #:root-partition-label root-partition-label - #:serial-console serial-console)) - (store-items (store-reference-closure (list closure-path))) - (manifest (string-append - "image-builder-version=\n" - image-builder-version - "\nimage-spec=\n" - (object->string image-spec) - "closure-path=\n" - closure-path - "\nstore-items=\n" - (string-join store-items "\n") - "\n")) - (hash (string-hash manifest)) - (image-store-path (string-append store-dir "/" hash "-fruix-bhyve-image-" - (operating-system-host-name os))) - (disk-image (string-append image-store-path "/disk.img")) - (esp-image (string-append image-store-path "/esp.img")) - (root-image (string-append image-store-path "/root.ufs"))) - (unless (file-exists? image-store-path) - (let* ((build-root (mktemp-directory "/tmp/fruix-bhyve-image-build.XXXXXX")) - (rootfs (string-append build-root "/rootfs")) - (image-rootfs (string-append build-root "/image-rootfs")) - (esp-stage (string-append build-root "/esp-stage")) - (temp-output (mktemp-directory (string-append store-dir "/.fruix-bhyve-image.XXXXXX"))) - (temp-disk (string-append build-root "/disk.img")) - (temp-esp (string-append build-root "/esp.img")) - (temp-root (string-append build-root "/root.ufs"))) - (dynamic-wind - (lambda () #t) - (lambda () - (materialize-rootfs os rootfs - #:store-dir store-dir - #:guile-prefix guile-prefix - #:guile-extra-prefix guile-extra-prefix - #:shepherd-prefix shepherd-prefix) - (copy-rootfs-for-image rootfs image-rootfs) - (copy-store-items-into-rootfs image-rootfs store-dir store-items) - (mkdir-p (string-append esp-stage "/EFI/BOOT")) - (copy-regular-file (string-append closure-path "/boot/loader.efi") - (string-append esp-stage "/EFI/BOOT/BOOTX64.EFI")) - (run-command "makefs" "-t" "ffs" "-T" "0" "-B" "little" - "-s" root-size - "-o" (string-append "label=" root-partition-label - ",version=2,bsize=32768,fsize=4096,density=16384") - temp-root image-rootfs) - (run-command "makefs" "-t" "msdos" "-T" "0" - "-o" "fat_type=32" - "-o" "sectors_per_cluster=1" - "-o" "volume_label=EFISYS" - "-o" "volume_id=305419896" - "-s" efi-size - temp-esp esp-stage) - (run-command "mkimg" "-s" "gpt" "-f" "raw" "-t" "0" - "-p" (string-append "efi/" efi-partition-label ":=" temp-esp) - "-p" (string-append "freebsd-ufs/" root-partition-label ":=" temp-root) - "-o" temp-disk) - (resize-gpt-image temp-disk disk-capacity) - (mkdir-p temp-output) - (copy-regular-file temp-disk (string-append temp-output "/disk.img")) - (copy-regular-file temp-esp (string-append temp-output "/esp.img")) - (copy-regular-file temp-root (string-append temp-output "/root.ufs")) - (write-file (string-append temp-output "/image-spec.scm") (object->string image-spec)) - (write-file (string-append temp-output "/closure-path") closure-path) - (write-file (string-append temp-output "/.references") (string-join store-items "\n")) - (write-file (string-append temp-output "/.fruix-package") manifest) - (chmod temp-output #o755) - (for-each (lambda (path) - (chmod path #o644)) - (list (string-append temp-output "/disk.img") - (string-append temp-output "/esp.img") - (string-append temp-output "/root.ufs") - (string-append temp-output "/image-spec.scm") - (string-append temp-output "/closure-path") - (string-append temp-output "/.references") - (string-append temp-output "/.fruix-package"))) - (rename-file temp-output image-store-path)) - (lambda () - (when (file-exists? build-root) - (delete-file-recursively build-root)))))) - `((image-store-path . ,image-store-path) - (disk-image . ,disk-image) - (esp-image . ,esp-image) - (root-image . ,root-image) - (closure-path . ,closure-path) - (host-base-stores . ,(assoc-ref closure 'host-base-stores)) - (native-base-stores . ,(assoc-ref closure 'native-base-stores)) - (fruix-runtime-stores . ,(assoc-ref closure 'fruix-runtime-stores)) - (freebsd-base-file . ,(assoc-ref closure 'freebsd-base-file)) - (freebsd-source-file . ,(assoc-ref closure 'freebsd-source-file)) - (freebsd-source-materializations-file . ,(assoc-ref closure 'freebsd-source-materializations-file)) - (materialized-source-stores . ,(assoc-ref closure 'materialized-source-stores)) - (host-base-provenance-file . ,(assoc-ref closure 'host-base-provenance-file)) - (store-layout-file . ,(assoc-ref closure 'store-layout-file)) - (image-spec . ,image-spec) - (store-items . ,store-items)))) - -(define* (materialize-installer-image os - #:key - (store-dir "/frx/store") - (guile-prefix "/tmp/guile-freebsd-validate-install") - (guile-extra-prefix "/tmp/guile-gnutls-freebsd-validate-install") - (shepherd-prefix "/tmp/shepherd-freebsd-validate-install") - (install-target-device "/dev/vtbd1") - (efi-size "64m") - (root-size "10g") - (disk-capacity #f) - (installer-host-name (string-append (operating-system-host-name os) - "-installer")) - (installer-efi-partition-label "efiboot") - (installer-root-partition-label "fruix-installer-root") - (target-efi-partition-label "efiboot") - (target-root-partition-label "fruix-root") - (serial-console "comconsole")) - (let* ((installer-os (installer-operating-system os - #:host-name installer-host-name - #:root-partition-label installer-root-partition-label)) - (target-closure (materialize-operating-system os - #:store-dir store-dir - #:guile-prefix guile-prefix - #:guile-extra-prefix guile-extra-prefix - #:shepherd-prefix shepherd-prefix)) - (installer-closure (materialize-operating-system installer-os - #:store-dir store-dir - #:guile-prefix guile-prefix - #:guile-extra-prefix guile-extra-prefix - #:shepherd-prefix shepherd-prefix)) - (target-closure-path (assoc-ref target-closure 'closure-path)) - (installer-closure-path (assoc-ref installer-closure 'closure-path)) - (target-store-items (store-reference-closure (list target-closure-path))) - (installer-store-items (store-reference-closure (list installer-closure-path))) - (combined-store-items (delete-duplicates (append installer-store-items target-store-items))) - (installer-image-spec (operating-system-installer-image-spec os - #:install-target-device install-target-device - #:installer-host-name installer-host-name - #:efi-size efi-size - #:root-size root-size - #:disk-capacity disk-capacity - #:installer-efi-partition-label installer-efi-partition-label - #:installer-root-partition-label installer-root-partition-label - #:target-efi-partition-label target-efi-partition-label - #:target-root-partition-label target-root-partition-label - #:serial-console serial-console)) - (image-spec (assoc-ref installer-image-spec 'installer-image)) - (target-install-spec (assoc-ref installer-image-spec 'target-install)) - (install-metadata (operating-system-install-metadata-object target-install-spec - target-closure-path - target-store-items)) - (installer-plan-directory "/var/lib/fruix/installer") - (installer-state-path (string-append installer-plan-directory "/state")) - (installer-log-path "/var/log/fruix-installer.log") - (manifest (string-append - "installer-image-builder-version=\n" - installer-image-builder-version - "\ninstaller-image-spec=\n" - (object->string installer-image-spec) - "installer-closure-path=\n" - installer-closure-path - "\ntarget-closure-path=\n" - target-closure-path - "\ncombined-store-items=\n" - (string-join combined-store-items "\n") - "\ntarget-store-items=\n" - (string-join target-store-items "\n") - "\ninstall-metadata=\n" - (object->string install-metadata) - "\n")) - (hash (string-hash manifest)) - (image-store-path (string-append store-dir "/" hash "-fruix-installer-image-" - (operating-system-host-name installer-os))) - (disk-image (string-append image-store-path "/disk.img")) - (esp-image (string-append image-store-path "/esp.img")) - (root-image (string-append image-store-path "/root.ufs"))) - (unless (file-exists? image-store-path) - (let* ((build-root (mktemp-directory "/tmp/fruix-installer-image-build.XXXXXX")) - (installer-rootfs (string-append build-root "/installer-rootfs")) - (target-rootfs (string-append build-root "/target-rootfs")) - (image-rootfs (string-append build-root "/image-rootfs")) - (esp-stage (string-append build-root "/esp-stage")) - (temp-output (mktemp-directory (string-append store-dir "/.fruix-installer-image.XXXXXX"))) - (temp-disk (string-append build-root "/disk.img")) - (temp-esp (string-append build-root "/esp.img")) - (temp-root (string-append build-root "/root.ufs")) - (plan-root (string-append image-rootfs installer-plan-directory))) - (dynamic-wind - (lambda () #t) - (lambda () - (populate-rootfs-from-closure installer-os installer-rootfs installer-closure-path) - (populate-rootfs-from-closure os target-rootfs target-closure-path) - (copy-rootfs-for-image installer-rootfs image-rootfs) - (mkdir-p plan-root) - (mkdir-p (string-append image-rootfs "/usr/local/libexec")) - (mkdir-p (string-append image-rootfs "/usr/local/etc/rc.d")) - (mkdir-p (string-append plan-root "/target-rootfs")) - (copy-tree-contents target-rootfs (string-append plan-root "/target-rootfs")) - (copy-store-items-into-rootfs image-rootfs store-dir combined-store-items) - (write-file (string-append plan-root "/store-items") - (string-append (string-join (map path-basename target-store-items) "\n") "\n")) - (write-file (string-append plan-root "/install.scm") - (object->string install-metadata)) - (copy-regular-file (string-append target-closure-path "/boot/loader.efi") - (string-append plan-root "/loader.efi")) - (write-file (string-append plan-root "/target-device") - (string-append install-target-device "\n")) - (write-file (string-append plan-root "/efi-size") - (string-append efi-size "\n")) - (write-file (string-append plan-root "/efi-partition-label") - (string-append target-efi-partition-label "\n")) - (write-file (string-append plan-root "/root-partition-label") - (string-append target-root-partition-label "\n")) - (write-file (string-append plan-root "/state") "pending\n") - (write-file (string-append image-rootfs "/usr/local/libexec/fruix-installer-run") - (render-installer-run-script store-dir installer-plan-directory)) - (write-file (string-append image-rootfs "/usr/local/etc/rc.d/fruix-installer") - (render-installer-rc-script installer-plan-directory)) - (chmod (string-append image-rootfs "/usr/local/libexec/fruix-installer-run") #o555) - (chmod (string-append image-rootfs "/usr/local/etc/rc.d/fruix-installer") #o555) - (mkdir-p (string-append esp-stage "/EFI/BOOT")) - (copy-regular-file (string-append installer-closure-path "/boot/loader.efi") - (string-append esp-stage "/EFI/BOOT/BOOTX64.EFI")) - (run-command "makefs" "-t" "ffs" "-T" "0" "-B" "little" - "-s" root-size - "-o" (string-append "label=" installer-root-partition-label - ",version=2,bsize=32768,fsize=4096,density=16384") - temp-root image-rootfs) - (run-command "makefs" "-t" "msdos" "-T" "0" - "-o" "fat_type=32" - "-o" "sectors_per_cluster=1" - "-o" "volume_label=EFISYS" - "-o" "volume_id=305419896" - "-s" efi-size - temp-esp esp-stage) - (run-command "mkimg" "-s" "gpt" "-f" "raw" "-t" "0" - "-p" (string-append "efi/" installer-efi-partition-label ":=" temp-esp) - "-p" (string-append "freebsd-ufs/" installer-root-partition-label ":=" temp-root) - "-o" temp-disk) - (resize-gpt-image temp-disk disk-capacity) - (mkdir-p temp-output) - (copy-regular-file temp-disk (string-append temp-output "/disk.img")) - (copy-regular-file temp-esp (string-append temp-output "/esp.img")) - (copy-regular-file temp-root (string-append temp-output "/root.ufs")) - (write-file (string-append temp-output "/installer-image-spec.scm") - (object->string installer-image-spec)) - (write-file (string-append temp-output "/installer-closure-path") installer-closure-path) - (write-file (string-append temp-output "/target-closure-path") target-closure-path) - (write-file (string-append temp-output "/.references") - (string-join combined-store-items "\n")) - (write-file (string-append temp-output "/.fruix-package") manifest) - (chmod temp-output #o755) - (for-each (lambda (path) - (chmod path #o644)) - (list (string-append temp-output "/disk.img") - (string-append temp-output "/esp.img") - (string-append temp-output "/root.ufs") - (string-append temp-output "/installer-image-spec.scm") - (string-append temp-output "/installer-closure-path") - (string-append temp-output "/target-closure-path") - (string-append temp-output "/.references") - (string-append temp-output "/.fruix-package"))) - (rename-file temp-output image-store-path)) - (lambda () - (when (file-exists? build-root) - (delete-file-recursively build-root)))))) - `((image-store-path . ,image-store-path) - (disk-image . ,disk-image) - (esp-image . ,esp-image) - (root-image . ,root-image) - (installer-closure-path . ,installer-closure-path) - (target-closure-path . ,target-closure-path) - (closure-path . ,installer-closure-path) - (image-spec . ,image-spec) - (installer-image-spec . ,installer-image-spec) - (install-spec . ,target-install-spec) - (installer-state-path . ,installer-state-path) - (installer-log-path . ,installer-log-path) - (install-target-device . ,install-target-device) - (host-base-stores . ,(assoc-ref target-closure 'host-base-stores)) - (native-base-stores . ,(assoc-ref target-closure 'native-base-stores)) - (fruix-runtime-stores . ,(assoc-ref target-closure 'fruix-runtime-stores)) - (freebsd-base-file . ,(assoc-ref target-closure 'freebsd-base-file)) - (freebsd-source-file . ,(assoc-ref target-closure 'freebsd-source-file)) - (freebsd-source-materializations-file . ,(assoc-ref target-closure 'freebsd-source-materializations-file)) - (materialized-source-stores . ,(assoc-ref target-closure 'materialized-source-stores)) - (host-base-provenance-file . ,(assoc-ref target-closure 'host-base-provenance-file)) - (store-layout-file . ,(assoc-ref target-closure 'store-layout-file)) - (store-items . ,combined-store-items) - (target-store-items . ,target-store-items) - (installer-store-items . ,installer-store-items)))) + #:use-module (fruix system freebsd model) + #:use-module (fruix system freebsd source) + #:use-module (fruix system freebsd media) + #:re-export (user-group + user-group? + user-group-name + user-group-gid + user-group-system? + user-account + user-account? + user-account-name + user-account-uid + user-account-group + user-account-supplementary-groups + user-account-comment + user-account-home + user-account-shell + user-account-system? + file-system + file-system? + file-system-device + file-system-mount-point + file-system-type + file-system-options + file-system-needed-for-boot? + operating-system + operating-system? + operating-system-host-name + operating-system-freebsd-base + operating-system-kernel + operating-system-bootloader + operating-system-base-packages + operating-system-users + operating-system-groups + operating-system-file-systems + operating-system-services + operating-system-loader-entries + operating-system-rc-conf-entries + operating-system-init-mode + operating-system-ready-marker + operating-system-root-authorized-keys + validate-operating-system + materialize-freebsd-source + operating-system-closure-spec + operating-system-install-spec + operating-system-image-spec + operating-system-installer-image-spec + installer-operating-system + materialize-operating-system + materialize-rootfs + install-operating-system + materialize-bhyve-image + materialize-installer-image + default-minimal-operating-system)) diff --git a/modules/fruix/system/freebsd/build.scm b/modules/fruix/system/freebsd/build.scm new file mode 100644 index 0000000..90074b6 --- /dev/null +++ b/modules/fruix/system/freebsd/build.scm @@ -0,0 +1,470 @@ +(define-module (fruix system freebsd build) + #:use-module (fruix packages freebsd) + #:use-module (fruix system freebsd model) + #:use-module (fruix system freebsd source) + #:use-module (fruix system freebsd utils) + #:use-module (guix build utils) + #:use-module (ice-9 format) + #:use-module (ice-9 hash-table) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-13) + #:export (host-freebsd-provenance + materialize-freebsd-package + materialize-prefix)) + +(define (host-freebsd-provenance) + (let ((src-git? (file-exists? "/usr/src/.git")) + (newvers "/usr/src/sys/conf/newvers.sh")) + `((freebsd-release . ,freebsd-release) + (freebsd-version-kru . ,(or (safe-command-output "freebsd-version" "-kru") "unknown")) + (uname . ,(or (safe-command-output "uname" "-a") "unknown")) + (usr-src-path . "/usr/src") + (usr-src-git-revision . ,(or (and src-git? + (safe-command-output "git" "-C" "/usr/src" "rev-parse" "HEAD")) + "absent")) + (usr-src-git-branch . ,(or (and src-git? + (safe-command-output "git" "-C" "/usr/src" "rev-parse" "--abbrev-ref" "HEAD")) + "absent")) + (usr-src-newvers-sha256 . ,(if (file-exists? newvers) + (file-hash newvers) + "absent"))))) + + +(define native-freebsd-build-version "1") + +(define (freebsd-native-build-system? build-system) + (not (not (memq build-system '(freebsd-kernel-build-system freebsd-world-build-system))))) + +(define (build-plan-ref plan key default) + (match (assoc key plan) + ((_ . value) value) + (#f default))) + +(define (make-flag->pair flag) + (match (string-split flag #\=) + ((name value ...) (cons name (string-join value "="))) + ((name) (cons name "yes")) + (_ (error (format #f "invalid make flag: ~a" flag))))) + +(define (native-build-kernconf-path plan) + (or (build-plan-ref plan 'kernconf-path #f) + (string-append (build-plan-ref plan 'source-root "/usr/src") + "/sys/" + (build-plan-ref plan 'target-arch "amd64") + "/conf/" + (build-plan-ref plan 'kernconf "GENERIC")))) + +(define (native-build-common-manifest plan) + (let* ((source-root (build-plan-ref plan 'source-root "/usr/src")) + (target (build-plan-ref plan 'target "amd64")) + (target-arch (build-plan-ref plan 'target-arch "amd64")) + (kernconf (build-plan-ref plan 'kernconf "GENERIC")) + (make-flags (build-plan-ref plan 'make-flags '())) + (kernconf-path (native-build-kernconf-path plan))) + (unless (file-exists? source-root) + (error (format #f "native FreeBSD source root does not exist: ~a" source-root))) + (unless (file-exists? kernconf-path) + (error (format #f "native FreeBSD kernconf does not exist: ~a" kernconf-path))) + `((build-version . ,native-freebsd-build-version) + (source-root . ,source-root) + (source-tree-identity-mode . "mtree:type,link,size,mode,sha256digest") + (source-tree-sha256 . ,(or (build-plan-ref plan 'materialized-source-tree-sha256 #f) + (native-build-source-tree-sha256 source-root))) + (target . ,target) + (target-arch . ,target-arch) + (kernconf . ,kernconf) + (kernconf-path . ,kernconf-path) + (kernconf-sha256 . ,(file-hash kernconf-path)) + (make-flags . ,make-flags)))) + +(define (native-build-declared-base plan) + `((name . ,(build-plan-ref plan 'base-name "default")) + (version-label . ,(build-plan-ref plan 'base-version-label freebsd-release)) + (release . ,(build-plan-ref plan 'base-release freebsd-release)) + (branch . ,(build-plan-ref plan 'base-branch "unknown")))) + +(define (native-build-declared-source plan) + `((name . ,(build-plan-ref plan 'base-source-name "default")) + (kind . ,(build-plan-ref plan 'base-source-kind 'local-tree)) + (url . ,(build-plan-ref plan 'base-source-url #f)) + (path . ,(build-plan-ref plan 'base-source-path #f)) + (ref . ,(build-plan-ref plan 'base-source-ref #f)) + (commit . ,(build-plan-ref plan 'base-source-commit #f)) + (sha256 . ,(build-plan-ref plan 'base-source-sha256 #f)))) + +(define (native-build-materialized-source plan) + `((store-path . ,(build-plan-ref plan 'materialized-source-store #f)) + (source-root . ,(build-plan-ref plan 'source-root "/usr/src")) + (info-file . ,(build-plan-ref plan 'materialized-source-info-file #f)) + (tree-sha256 . ,(build-plan-ref plan 'materialized-source-tree-sha256 #f)) + (cache-path . ,(build-plan-ref plan 'materialized-source-cache-path #f)) + (effective-source . ((kind . ,(build-plan-ref plan 'effective-source-kind #f)) + (url . ,(build-plan-ref plan 'effective-source-url #f)) + (path . ,(build-plan-ref plan 'effective-source-path #f)) + (ref . ,(build-plan-ref plan 'effective-source-ref #f)) + (commit . ,(build-plan-ref plan 'effective-source-commit #f)) + (sha256 . ,(build-plan-ref plan 'effective-source-sha256 #f)))))) + +(define (native-build-manifest-string package input-paths) + (let* ((plan (freebsd-package-install-plan package)) + (common (native-build-common-manifest plan)) + (declared-base (native-build-declared-base plan)) + (declared-source (native-build-declared-source plan)) + (materialized-source (native-build-materialized-source plan)) + (keep-paths (build-plan-ref plan 'keep-paths '())) + (prune-paths (build-plan-ref plan 'prune-paths '()))) + (string-append + "name=" (freebsd-package-name package) "\n" + "version=" (freebsd-package-version package) "\n" + "build-system=" (symbol->string (freebsd-package-build-system package)) "\n" + "inputs=" (string-join input-paths ",") "\n" + "declared-base=\n" + (object->string declared-base) + "\ndeclared-source=\n" + (object->string declared-source) + "\nmaterialized-source=\n" + (object->string materialized-source) + "\nnative-build-common=\n" + (object->string common) + "\nkeep-paths=\n" + (object->string keep-paths) + "\nprune-paths=\n" + (object->string prune-paths)))) + +(define (copy-build-manifest-string package input-paths) + (string-append + "name=" (freebsd-package-name package) "\n" + "version=" (freebsd-package-version package) "\n" + "build-system=" (symbol->string (freebsd-package-build-system package)) "\n" + "inputs=" (string-join input-paths ",") "\n" + "install-plan-signature=\n" + (string-join (map install-plan-signature + (freebsd-package-install-plan package)) + "\n"))) + +(define (package-manifest-string package input-paths) + (if (freebsd-native-build-system? (freebsd-package-build-system package)) + (native-build-manifest-string package input-paths) + (copy-build-manifest-string package input-paths))) + +(define (current-build-jobs) + (or (getenv "FRUIX_FREEBSD_BUILD_JOBS") + (safe-command-output "sysctl" "-n" "hw.ncpu") + "1")) + +(define (native-build-root common) + (string-append "/var/tmp/fruix-freebsd-native-build-" + (string-hash (object->string common)))) + +(define (native-make-arguments common _build-root) + (append + (list "-C" (assoc-ref common 'source-root) + (string-append "TARGET=" (assoc-ref common 'target)) + (string-append "TARGET_ARCH=" (assoc-ref common 'target-arch)) + (string-append "KERNCONF=" (assoc-ref common 'kernconf))) + (assoc-ref common 'make-flags))) + +(define* (make-command-string common build-root target #:key (parallel? #f) (destdir #f)) + (string-join + (append + (list "env" (string-append "MAKEOBJDIRPREFIX=" build-root "/obj") "make") + (if parallel? + (list (string-append "-j" (current-build-jobs))) + '()) + (native-make-arguments common build-root) + (if destdir + (list (string-append "DESTDIR=" destdir)) + '()) + (list target)) + " ")) + +(define (run-command/log log-file command) + (mkdir-p (dirname log-file)) + (let ((status (system* "sh" "-c" (string-append command " >" log-file " 2>&1")))) + (unless (zero? status) + (error (format #f "command failed; see ~a: ~a" log-file command))))) + +(define (ensure-native-build-root common build-root) + (mkdir-p build-root) + (mkdir-p (string-append build-root "/logs")) + (mkdir-p (string-append build-root "/stamps")) + (write-file (string-append build-root "/build-parameters.scm") + (object->string common))) + +(define (ensure-native-buildworld common build-root) + (let ((stamp (string-append build-root "/stamps/buildworld.done"))) + (ensure-native-build-root common build-root) + (unless (file-exists? stamp) + (run-command/log (string-append build-root "/logs/buildworld.log") + (make-command-string common build-root "buildworld" #:parallel? #t)) + (write-file stamp "ok\n")))) + +(define (ensure-native-buildkernel common build-root) + (let ((stamp (string-append build-root "/stamps/buildkernel-" (assoc-ref common 'kernconf) ".done"))) + (ensure-native-buildworld common build-root) + (unless (file-exists? stamp) + (run-command/log (string-append build-root "/logs/buildkernel-" (assoc-ref common 'kernconf) ".log") + (make-command-string common build-root "buildkernel" #:parallel? #t)) + (write-file stamp "ok\n")))) + +(define (prune-stage-paths stage-root paths) + (for-each (lambda (path) + (delete-path-if-exists (string-append stage-root "/" path))) + paths)) + +(define (select-stage-paths stage-root paths) + (let ((selected-root (string-append stage-root ".selected"))) + (delete-path-if-exists selected-root) + (mkdir-p selected-root) + (for-each (lambda (path) + (let ((source (string-append stage-root "/" path)) + (target (string-append selected-root "/" path))) + (unless (or (file-exists? source) + (false-if-exception (readlink source))) + (error (format #f "native stage path is missing: ~a" source))) + (copy-node source target))) + paths) + selected-root)) +(define (native-build-output-metadata package common build-root stage-root) + (let ((plan (freebsd-package-install-plan package))) + `((package . ,(freebsd-package-name package)) + (version . ,(freebsd-package-version package)) + (declared-base . ,(native-build-declared-base plan)) + (declared-source . ,(native-build-declared-source plan)) + (materialized-source . ,(native-build-materialized-source plan)) + (build-system . ,(freebsd-package-build-system package)) + (source-root . ,(assoc-ref common 'source-root)) + (source-tree-sha256 . ,(assoc-ref common 'source-tree-sha256)) + (target . ,(assoc-ref common 'target)) + (target-arch . ,(assoc-ref common 'target-arch)) + (kernconf . ,(assoc-ref common 'kernconf)) + (kernconf-path . ,(assoc-ref common 'kernconf-path)) + (kernconf-sha256 . ,(assoc-ref common 'kernconf-sha256)) + (make-flags . ,(assoc-ref common 'make-flags)) + (keep-paths . ,(build-plan-ref plan 'keep-paths '())) + (prune-paths . ,(build-plan-ref plan 'prune-paths '())) + (build-root . ,build-root) + (stage-root . ,stage-root) + (buildworld-log . ,(string-append build-root "/logs/buildworld.log")) + (buildkernel-log . ,(string-append build-root "/logs/buildkernel-" (assoc-ref common 'kernconf) ".log")) + (install-log . ,(string-append build-root "/logs/install-" (freebsd-package-name package) ".log"))))) + +(define (materialize-native-freebsd-package package input-paths manifest output-path) + (let* ((plan (freebsd-package-install-plan package)) + (common (native-build-common-manifest plan)) + (build-root (native-build-root common)) + (stage-root (string-append build-root "/stage-" (freebsd-package-name package) "-" (string-hash manifest))) + (install-log (string-append build-root "/logs/install-" (freebsd-package-name package) ".log")) + (final-stage-root + (case (freebsd-package-build-system package) + ((freebsd-world-build-system) + (ensure-native-buildworld common build-root) + (delete-path-if-exists stage-root) + (mkdir-p stage-root) + (run-command/log install-log + (string-append (make-command-string common build-root "installworld" #:destdir stage-root) + " && " + (make-command-string common build-root "distribution" #:destdir stage-root))) + (let* ((keep-paths (build-plan-ref plan 'keep-paths '())) + (selected-root (if (null? keep-paths) + stage-root + (select-stage-paths stage-root keep-paths)))) + (prune-stage-paths selected-root (build-plan-ref plan 'prune-paths '())) + selected-root)) + ((freebsd-kernel-build-system) + (ensure-native-buildkernel common build-root) + (delete-path-if-exists stage-root) + (mkdir-p stage-root) + (run-command/log install-log + (make-command-string common build-root "installkernel" #:destdir stage-root)) + stage-root) + (else + (error (format #f "unsupported native FreeBSD build system: ~a" + (freebsd-package-build-system package))))))) + (mkdir-p output-path) + (stage-tree-into-output final-stage-root output-path) + (write-file (string-append output-path "/.references") + (string-join input-paths "\n")) + (write-file (string-append output-path "/.fruix-package") manifest) + (write-file (string-append output-path "/.freebsd-native-build-info.scm") + (object->string (native-build-output-metadata package common build-root final-stage-root))))) + +(define (package-with-install-plan package install-plan) + (freebsd-package + #:name (freebsd-package-name package) + #:version (freebsd-package-version package) + #:build-system (freebsd-package-build-system package) + #:inputs (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-plan install-plan)) + +(define (plan-freebsd-source plan) + (freebsd-source #:name (build-plan-ref plan 'base-source-name "default") + #:kind (build-plan-ref plan 'base-source-kind 'local-tree) + #:url (build-plan-ref plan 'base-source-url #f) + #:path (build-plan-ref plan 'base-source-path #f) + #:ref (build-plan-ref plan 'base-source-ref #f) + #:commit (build-plan-ref plan 'base-source-commit #f) + #:sha256 (build-plan-ref plan 'base-source-sha256 #f))) + +(define (source-cache-key source) + (string-hash (object->string (freebsd-source-spec source)))) + +(define (materialize-freebsd-source/cached source store-dir source-cache) + (let* ((key (source-cache-key source)) + (cached (hash-ref source-cache key #f))) + (or cached + (let ((result (materialize-freebsd-source source #:store-dir store-dir))) + (hash-set! source-cache key result) + result)))) + +(define (plan-with-materialized-source plan source-result) + (let* ((effective (assoc-ref source-result 'effective-source)) + (overrides + `((source-root . ,(assoc-ref source-result 'source-root)) + (materialized-source-store . ,(assoc-ref source-result 'source-store-path)) + (materialized-source-info-file . ,(assoc-ref source-result 'source-info-file)) + (materialized-source-tree-sha256 . ,(assoc-ref source-result 'source-tree-sha256)) + (materialized-source-cache-path . ,(assoc-ref source-result 'cache-path)) + (effective-source-kind . ,(assoc-ref effective 'kind)) + (effective-source-url . ,(assoc-ref effective 'url)) + (effective-source-path . ,(assoc-ref effective 'path)) + (effective-source-ref . ,(assoc-ref effective 'ref)) + (effective-source-commit . ,(assoc-ref effective 'commit)) + (effective-source-sha256 . ,(assoc-ref effective 'sha256))))) + (append overrides plan))) + +(define* (materialize-freebsd-package package store-dir cache #:optional source-cache) + (let* ((source-cache (or source-cache (make-hash-table))) + (input-paths (map (lambda (input) + (materialize-freebsd-package input store-dir cache source-cache)) + (freebsd-package-inputs package))) + (prepared-package + (if (freebsd-native-build-package? package) + (let* ((source (plan-freebsd-source (freebsd-package-install-plan package))) + (source-result (materialize-freebsd-source/cached source store-dir source-cache)) + (plan (plan-with-materialized-source (freebsd-package-install-plan package) + source-result))) + (package-with-install-plan package plan)) + package)) + (effective-input-paths + (if (freebsd-native-build-package? package) + (cons (build-plan-ref (freebsd-package-install-plan prepared-package) + 'materialized-source-store + #f) + input-paths) + input-paths)) + (effective-input-paths (filter identity effective-input-paths)) + (manifest (package-manifest-string prepared-package effective-input-paths)) + (cache-key (string-hash manifest)) + (cached (hash-ref cache cache-key #f))) + (if cached + cached + (let* ((hash (string-hash manifest)) + (output-path (string-append store-dir "/" hash "-" + (freebsd-package-name prepared-package) + "-" + (freebsd-package-version prepared-package)))) + (unless (file-exists? output-path) + (case (freebsd-package-build-system prepared-package) + ((copy-build-system) + (mkdir-p output-path) + (for-each (lambda (entry) + (materialize-plan-entry output-path entry)) + (freebsd-package-install-plan prepared-package)) + (write-file (string-append output-path "/.references") + (string-join effective-input-paths "\n")) + (write-file (string-append output-path "/.fruix-package") manifest)) + ((freebsd-world-build-system freebsd-kernel-build-system) + (materialize-native-freebsd-package prepared-package effective-input-paths manifest output-path)) + (else + (error (format #f "unsupported package build system: ~a" + (freebsd-package-build-system prepared-package)))))) + (hash-set! cache cache-key output-path) + output-path)))) + + +(define (sanitize-materialized-prefix name output-path) + (cond + ((string=? name "fruix-guile-extra") + (rewrite-text-file + (string-append output-path "/share/guile/site/3.0/fibers/config.scm") + '(("((getenv \"FIBERS_BUILD_DIR\")\n => (lambda (builddir) (in-vicinity builddir \".libs\")))\n (else \"/tmp/guile-gnutls-freebsd-validate-install/lib/guile/3.0/extensions\"))" + . "((getenv \"FIBERS_BUILD_DIR\")\n => (lambda (builddir) (in-vicinity builddir \".libs\")))\n ((getenv \"GUILE_EXTENSIONS_PATH\"))\n (else \"/usr/local/lib/guile/3.0/extensions\"))"))) + (rewrite-text-file + (string-append output-path "/share/guile/site/3.0/gnutls.scm") + '(("\"/tmp/guile-gnutls-freebsd-validate-install/lib/guile/3.0/extensions\"" + . "(or (getenv \"GUILE_EXTENSIONS_PATH\") \"/usr/local/lib/guile/3.0/extensions\")"))) + (delete-file-if-exists (string-append output-path "/lib/guile/3.0/site-ccache/fibers/config.go")) + (delete-file-if-exists (string-append output-path "/lib/guile/3.0/site-ccache/gnutls.go"))) + ((string=? name "fruix-shepherd-runtime") + (rewrite-text-file + (string-append output-path "/share/guile/site/3.0/shepherd/config.scm") + '(("(define Prefix-dir \"/tmp/shepherd-freebsd-validate-install\")" + . "(define Prefix-dir \"/frx\")") + ("(define %localstatedir \"/tmp/shepherd-freebsd-validate-install/var\")" + . "(define %localstatedir \"/var\")") + ("(define %runstatedir \"/tmp/shepherd-freebsd-validate-install/var/run\")" + . "(define %runstatedir \"/var/run\")") + ("(define %sysconfdir \"/tmp/shepherd-freebsd-validate-install/etc\")" + . "(define %sysconfdir \"/etc\")") + ("(define %localedir \"/tmp/shepherd-freebsd-validate-install/share/locale\")" + . "(define %localedir \"/usr/share/locale\")") + ("(define %pkglibdir \"/tmp/shepherd-freebsd-validate-install/lib/shepherd\")" + . "(define %pkglibdir \"/usr/local/lib/shepherd\")"))) + (delete-file-if-exists (string-append output-path "/lib/guile/3.0/site-ccache/shepherd/config.go")))) + #t) + +(define (prefix-manifest-string source-path extra-files) + (string-append + "prefix-materializer-version=" prefix-materializer-version "\n" + "prefix-source=" source-path "\n" + (path-signature source-path) + (if (null? extra-files) + "" + (string-append + "\nextra-files=\n" + (string-join + (map (lambda (entry) + (string-append (cdr entry) "\n" (path-signature (car entry)))) + extra-files) + "\n"))))) + +(define (copy-extra-node source destination) + (let ((kind (stat:type (lstat source)))) + (mkdir-p (dirname destination)) + (case kind + ((symlink) + (unless (or (file-exists? destination) + (false-if-exception (readlink destination))) + (let ((target (readlink source))) + (symlink target destination) + (unless (string-prefix? "/" target) + (copy-extra-node (string-append (dirname source) "/" target) + (string-append (dirname destination) "/" target)))))) + (else + (unless (file-exists? destination) + (copy-node source destination)))))) + +(define* (materialize-prefix source-path name version store-dir #:key (extra-files '())) + (let* ((manifest (prefix-manifest-string source-path extra-files)) + (hash (string-hash manifest)) + (output-path (string-append store-dir "/" hash "-" name "-" version))) + (unless (file-exists? output-path) + (mkdir-p output-path) + (for-each (lambda (entry) + (copy-node (string-append source-path "/" entry) + (string-append output-path "/" entry))) + (directory-entries source-path)) + (for-each (lambda (entry) + (copy-extra-node (car entry) + (string-append output-path "/" (cdr entry)))) + extra-files) + (sanitize-materialized-prefix name output-path) + (write-file (string-append output-path "/.fruix-package") manifest)) + output-path)) + diff --git a/modules/fruix/system/freebsd/media.scm b/modules/fruix/system/freebsd/media.scm new file mode 100644 index 0000000..4cb1702 --- /dev/null +++ b/modules/fruix/system/freebsd/media.scm @@ -0,0 +1,1031 @@ +(define-module (fruix system freebsd media) + #:use-module (fruix packages freebsd) + #:use-module (fruix system freebsd build) + #:use-module (fruix system freebsd model) + #:use-module (fruix system freebsd render) + #:use-module (fruix system freebsd source) + #:use-module (fruix system freebsd utils) + #:use-module (guix build utils) + #:use-module (ice-9 format) + #:use-module (ice-9 hash-table) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-13) + #:export (operating-system-install-spec + operating-system-image-spec + operating-system-installer-image-spec + installer-operating-system + materialize-operating-system + materialize-rootfs + install-operating-system + materialize-bhyve-image + materialize-installer-image)) + +(define (same-file-contents? a b) + (zero? (system* "cmp" "-s" a b))) + +(define (merge-output-into-tree output-path tree-root) + (define (walk relative) + (let ((source (if (string-null? relative) + output-path + (string-append output-path "/" relative)))) + (for-each + (lambda (entry) + (unless (or (member entry '(".references" ".fruix-package")) + (string-prefix? "." entry)) + (let* ((entry-relative (if (string-null? relative) + entry + (string-append relative "/" entry))) + (source-entry (string-append output-path "/" entry-relative)) + (target-entry (string-append tree-root "/" entry-relative)) + (st (lstat source-entry))) + (if (eq? 'directory (stat:type st)) + (begin + (mkdir-p target-entry) + (walk entry-relative)) + (begin + (mkdir-p (dirname target-entry)) + (if (file-exists? target-entry) + (let ((existing (false-if-exception (readlink target-entry)))) + (unless (or (and existing + (string=? existing source-entry)) + (and existing + (file-exists? existing) + (same-file-contents? existing source-entry))) + (error (format #f "tree collision for ~a" target-entry)))) + (symlink source-entry target-entry))))))) + (directory-entries source)))) + (mkdir-p tree-root) + (walk "")) + +(define (hash-table-values table) + (hash-fold (lambda (_ value result) + (cons value result)) + '() + table)) + + +(define* (materialize-operating-system os + #:key + (store-dir "/frx/store") + (guile-prefix "/tmp/guile-freebsd-validate-install") + (guile-extra-prefix "/tmp/guile-gnutls-freebsd-validate-install") + (shepherd-prefix "/tmp/shepherd-freebsd-validate-install")) + (validate-operating-system os) + (let* ((cache (make-hash-table)) + (source-cache (make-hash-table)) + (kernel-package (operating-system-kernel os)) + (bootloader-package (operating-system-bootloader os)) + (base-packages (operating-system-base-packages os)) + (kernel-store (materialize-freebsd-package kernel-package store-dir cache source-cache)) + (bootloader-store (materialize-freebsd-package bootloader-package store-dir cache source-cache)) + (base-package-stores (map (lambda (package) + (materialize-freebsd-package package store-dir cache source-cache)) + base-packages)) + (base-package-pairs (map cons base-packages base-package-stores)) + (store-classification + (append (list (cons kernel-package kernel-store) + (cons bootloader-package bootloader-store)) + base-package-pairs)) + (guile-runtime-extra-files + '(("/usr/local/lib/libgc-threaded.so.1" . "lib/libgc-threaded.so.1") + ("/usr/local/lib/libffi.so.8" . "lib/libffi.so.8") + ("/usr/local/lib/libintl.so.8" . "lib/libintl.so.8") + ("/usr/local/lib/libunistring.so.5" . "lib/libunistring.so.5") + ("/usr/local/lib/libiconv.so.2" . "lib/libiconv.so.2") + ("/usr/local/lib/libgmp.so.10" . "lib/libgmp.so.10"))) + (guile-extra-runtime-files + '(("/usr/local/lib/libevent-2.1.so.7" . "lib/libevent-2.1.so.7") + ("/usr/local/lib/libgnutls.so.30" . "lib/libgnutls.so.30") + ("/usr/local/lib/libp11-kit.so.0" . "lib/libp11-kit.so.0") + ("/usr/local/lib/libidn2.so.0" . "lib/libidn2.so.0") + ("/usr/local/lib/libtasn1.so.6" . "lib/libtasn1.so.6") + ("/usr/local/lib/libhogweed.so.6" . "lib/libhogweed.so.6") + ("/usr/local/lib/libnettle.so.8" . "lib/libnettle.so.8"))) + (guile-store (materialize-prefix guile-prefix "fruix-guile-runtime" "3.0" store-dir + #:extra-files guile-runtime-extra-files)) + (guile-extra-store (materialize-prefix guile-extra-prefix "fruix-guile-extra" "3.0" store-dir + #:extra-files (append guile-runtime-extra-files + guile-extra-runtime-files))) + (shepherd-store (materialize-prefix shepherd-prefix "fruix-shepherd-runtime" "1.0.9" store-dir)) + (host-base-stores + (delete-duplicates + (map cdr + (filter (lambda (entry) + (freebsd-host-staged-package? (car entry))) + store-classification)))) + (native-base-stores + (delete-duplicates + (map cdr + (filter (lambda (entry) + (freebsd-native-build-package? (car entry))) + store-classification)))) + (fruix-runtime-stores (list guile-store guile-extra-store shepherd-store)) + (source-materializations + (delete-duplicates (hash-table-values source-cache))) + (materialized-source-stores + (delete-duplicates (map (lambda (result) + (assoc-ref result 'source-store-path)) + source-materializations))) + (metadata-files + `(("metadata/freebsd-base.scm" + . ,(object->string (freebsd-base-spec (operating-system-freebsd-base os)))) + ("metadata/freebsd-source.scm" + . ,(object->string (freebsd-source-spec (freebsd-base-source (operating-system-freebsd-base os))))) + ("metadata/freebsd-source-materializations.scm" + . ,(object->string (map freebsd-source-materialization-spec source-materializations))) + ("metadata/host-base-provenance.scm" + . ,(object->string (host-freebsd-provenance))) + ("metadata/store-layout.scm" + . ,(object->string + `((freebsd-base . ,(freebsd-base-spec (operating-system-freebsd-base os))) + (freebsd-source . ,(freebsd-source-spec (freebsd-base-source (operating-system-freebsd-base os)))) + (materialized-source-store-count . ,(length materialized-source-stores)) + (materialized-source-stores . ,materialized-source-stores) + (host-base-store-count . ,(length host-base-stores)) + (host-base-stores . ,host-base-stores) + (native-base-store-count . ,(length native-base-stores)) + (native-base-stores . ,native-base-stores) + (fruix-runtime-store-count . ,(length fruix-runtime-stores)) + (fruix-runtime-stores . ,fruix-runtime-stores) + (host-base-replacement-order . ,%freebsd-host-staged-replacement-order) + (init-mode . ,(operating-system-init-mode os))))))) + (generated-files (append (operating-system-generated-files os + #:guile-store guile-store + #:guile-extra-store guile-extra-store + #:shepherd-store shepherd-store) + metadata-files + `(("usr/local/etc/rc.d/fruix-activate" + . ,(render-activation-rc-script)) + ("usr/local/etc/rc.d/fruix-shepherd" + . ,(render-rc-script shepherd-store guile-store guile-extra-store))))) + (references (delete-duplicates (append materialized-source-stores host-base-stores native-base-stores fruix-runtime-stores))) + (manifest (string-append + "closure-spec=\n" + (object->string (operating-system-closure-spec os)) + "generated-files=\n" + (string-join (map (lambda (entry) + (string-append (car entry) "\n" (cdr entry))) + generated-files) + "\n") + "\nreferences=\n" + (string-join references "\n"))) + (hash (string-hash manifest)) + (closure-path (string-append store-dir "/" hash "-fruix-system-" + (operating-system-host-name os)))) + (unless (file-exists? closure-path) + (mkdir-p closure-path) + (mkdir-p (string-append closure-path "/boot/kernel")) + (symlink (string-append kernel-store "/boot/kernel/kernel") + (string-append closure-path "/boot/kernel/kernel")) + (symlink (string-append kernel-store "/boot/kernel/linker.hints") + (string-append closure-path "/boot/kernel/linker.hints")) + (for-each + (lambda (entry) + (let ((name (car entry))) + (symlink (string-append bootloader-store "/boot/" name) + (string-append closure-path "/boot/" name)))) + '(("loader") ("loader.efi") ("device.hints") ("defaults") ("lua"))) + (mkdir-p (string-append closure-path "/profile")) + (for-each (lambda (output) + (merge-output-into-tree output (string-append closure-path "/profile"))) + base-package-stores) + (for-each + (lambda (entry) + (write-file (string-append closure-path "/" (car entry)) (cdr entry))) + generated-files) + (chmod (string-append closure-path "/activate") #o555) + (when (file-exists? (string-append closure-path "/etc/master.passwd")) + (chmod (string-append closure-path "/etc/master.passwd") #o600)) + (chmod (string-append closure-path "/usr/local/etc/rc.d/fruix-activate") #o555) + (chmod (string-append closure-path "/usr/local/etc/rc.d/fruix-shepherd") #o555) + (when (file-exists? (string-append closure-path "/boot/fruix-pid1")) + (chmod (string-append closure-path "/boot/fruix-pid1") #o555)) + (write-file (string-append closure-path "/parameters.scm") + (object->string (operating-system-closure-spec os))) + (write-file (string-append closure-path "/.references") + (string-join references "\n")) + (write-file (string-append closure-path "/.fruix-package") manifest)) + `((closure-path . ,closure-path) + (kernel-store . ,kernel-store) + (bootloader-store . ,bootloader-store) + (guile-store . ,guile-store) + (guile-extra-store . ,guile-extra-store) + (shepherd-store . ,shepherd-store) + (base-package-stores . ,base-package-stores) + (host-base-stores . ,host-base-stores) + (native-base-stores . ,native-base-stores) + (fruix-runtime-stores . ,fruix-runtime-stores) + (freebsd-base-file . ,(string-append closure-path "/metadata/freebsd-base.scm")) + (freebsd-source-file . ,(string-append closure-path "/metadata/freebsd-source.scm")) + (freebsd-source-materializations-file . ,(string-append closure-path "/metadata/freebsd-source-materializations.scm")) + (materialized-source-stores . ,materialized-source-stores) + (host-base-provenance-file . ,(string-append closure-path "/metadata/host-base-provenance.scm")) + (store-layout-file . ,(string-append closure-path "/metadata/store-layout.scm")) + (generated-files . ,(map car generated-files)) + (references . ,references)))) + +(define (symlink-force target link-name) + (when (or (file-exists? link-name) (false-if-exception (readlink link-name))) + (delete-file link-name)) + (mkdir-p (dirname link-name)) + (symlink target link-name)) + +(define (populate-rootfs-from-closure os rootfs closure-path) + (when (file-exists? rootfs) + (delete-file-recursively rootfs)) + (mkdir-p rootfs) + (for-each (lambda (dir) + (mkdir-p (string-append rootfs dir))) + '("/run" "/boot" "/etc" "/etc/ssh" "/usr" "/usr/share" "/usr/local" "/usr/local/etc" + "/usr/local/etc/rc.d" "/var" "/var/cron" "/var/db" "/var/lib" "/var/lib/fruix" + "/var/log" "/var/run" "/tmp" "/dev" "/root" "/home")) + (chmod (string-append rootfs "/tmp") #o1777) + (symlink-force closure-path (string-append rootfs "/run/current-system")) + (symlink-force "/run/current-system/activate" (string-append rootfs "/activate")) + (for-each (lambda (dir) + (symlink-force (string-append "/run/current-system/profile/" dir) + (string-append rootfs "/" dir))) + '("bin" "sbin" "lib" "libexec")) + (for-each (lambda (dir) + (symlink-force (string-append "/run/current-system/profile/usr/" dir) + (string-append rootfs "/usr/" dir))) + '("bin" "lib" "sbin" "libexec")) + (when (file-exists? (string-append closure-path "/profile/usr/share/locale")) + (symlink-force "/run/current-system/profile/usr/share/locale" + (string-append rootfs "/usr/share/locale"))) + (for-each (lambda (path) + (symlink-force (string-append "/run/current-system/profile/etc/" path) + (string-append rootfs "/etc/" path))) + '("rc" "rc.subr" "rc.shutdown" "rc.d" "defaults" + "devd.conf" "network.subr" "newsyslog.conf" "syslog.conf")) + (for-each (lambda (path) + (symlink-force (string-append "/run/current-system/etc/" path) + (string-append rootfs "/etc/" path))) + '("rc.conf" "fstab" "hosts" "shells" "motd" "ttys")) + (for-each (lambda (path) + (copy-regular-file (string-append closure-path "/etc/" path) + (string-append rootfs "/etc/" path))) + '("passwd" "master.passwd" "group" "login.conf")) + (when (file-exists? (string-append closure-path "/etc/ssh/sshd_config")) + (symlink-force "/run/current-system/etc/ssh/sshd_config" + (string-append rootfs "/etc/ssh/sshd_config"))) + (for-each (lambda (path) + (symlink-force (string-append "/run/current-system/boot/" path) + (string-append rootfs "/boot/" path))) + '("kernel" "loader" "loader.efi" "device.hints" "defaults" "lua" "loader.conf")) + (symlink-force "/run/current-system/usr/local/etc/rc.d/fruix-activate" + (string-append rootfs "/usr/local/etc/rc.d/fruix-activate")) + (symlink-force "/run/current-system/usr/local/etc/rc.d/fruix-shepherd" + (string-append rootfs "/usr/local/etc/rc.d/fruix-shepherd")) + `((rootfs . ,rootfs) + (closure-path . ,closure-path) + (ready-marker . ,(operating-system-ready-marker os)) + (rc-script . ,(string-append closure-path "/usr/local/etc/rc.d/fruix-shepherd")))) + +(define* (materialize-rootfs os rootfs + #:key + (store-dir "/frx/store") + (guile-prefix "/tmp/guile-freebsd-validate-install") + (guile-extra-prefix "/tmp/guile-gnutls-freebsd-validate-install") + (shepherd-prefix "/tmp/shepherd-freebsd-validate-install")) + (let* ((closure (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 closure 'closure-path))) + (populate-rootfs-from-closure os rootfs closure-path))) + +(define (assoc-remove keys entries) + (filter (lambda (entry) + (not (member (car entry) keys))) + entries)) + +(define (ensure-installer-groups groups) + (append groups + (filter (lambda (group) + (not (any (lambda (existing) + (string=? (user-group-name existing) + (user-group-name group))) + groups))) + (list (user-group #:name "sshd" #:gid 22 #:system? #t) + (user-group #:name "_dhcp" #:gid 65 #:system? #t))))) + +(define (ensure-installer-users users) + (append users + (filter (lambda (user) + (not (any (lambda (existing) + (string=? (user-account-name existing) + (user-account-name user))) + users))) + (list (user-account #:name "sshd" + #:uid 22 + #:group "sshd" + #:comment "Secure Shell Daemon" + #:home "/var/empty" + #:shell "/usr/sbin/nologin" + #:system? #t) + (user-account #:name "_dhcp" + #:uid 65 + #:group "_dhcp" + #:comment "dhcp programs" + #:home "/var/empty" + #:shell "/usr/sbin/nologin" + #:system? #t))))) + +(define* (installer-operating-system os + #:key + (host-name (string-append (operating-system-host-name os) + "-installer")) + (root-partition-label "fruix-installer-root") + (ready-marker "/var/lib/fruix/installer/ready")) + (operating-system + #:host-name host-name + #:freebsd-base (operating-system-freebsd-base os) + #:kernel (operating-system-kernel os) + #:bootloader (operating-system-bootloader os) + #:base-packages (operating-system-base-packages os) + #:users (ensure-installer-users (operating-system-users os)) + #:groups (ensure-installer-groups (operating-system-groups os)) + #:file-systems (list (file-system #:device (string-append "/dev/gpt/" root-partition-label) + #:mount-point "/" + #:type "ufs" + #:options "rw" + #:needed-for-boot? #t) + (file-system #:device "devfs" + #:mount-point "/dev" + #:type "devfs" + #:options "rw" + #:needed-for-boot? #t) + (file-system #:device "tmpfs" + #:mount-point "/tmp" + #:type "tmpfs" + #:options "rw,size=64m")) + #:services '(shepherd ready-marker sshd) + #:loader-entries (operating-system-loader-entries os) + #:rc-conf-entries (append (assoc-remove '("sshd_enable" "fruix_installer_enable") + (operating-system-rc-conf-entries os)) + '(("sshd_enable" . "YES") + ("fruix_installer_enable" . "YES"))) + #:init-mode 'freebsd-init+rc.d-shepherd + #:ready-marker ready-marker + #:root-authorized-keys (operating-system-root-authorized-keys os))) + +(define* (operating-system-install-spec os + #:key + target + (target-kind 'raw-file) + (boot-mode 'uefi) + (partition-scheme 'gpt) + (efi-size "64m") + (root-size #f) + (disk-capacity #f) + (efi-partition-label "efiboot") + (root-partition-label "fruix-root") + (serial-console "comconsole")) + `((host-name . ,(operating-system-host-name os)) + (freebsd-base . ,(freebsd-base-spec (operating-system-freebsd-base os))) + (install-mode . non-interactive) + (target . ,target) + (target-kind . ,target-kind) + (boot-mode . ,boot-mode) + (partition-scheme . ,partition-scheme) + (efi-size . ,efi-size) + (root-size . ,root-size) + (disk-capacity . ,disk-capacity) + (efi-partition-label . ,efi-partition-label) + (root-partition-label . ,root-partition-label) + (serial-console . ,serial-console) + (init-mode . ,(operating-system-init-mode os)))) + +(define* (operating-system-image-spec os + #:key + (boot-mode 'uefi) + (image-format 'raw) + (partition-scheme 'gpt) + (efi-size "64m") + (root-size "256m") + (disk-capacity #f) + (efi-partition-label "efiboot") + (root-partition-label "fruix-root") + (serial-console "comconsole")) + `((host-name . ,(operating-system-host-name os)) + (freebsd-base . ,(freebsd-base-spec (operating-system-freebsd-base os))) + (boot-mode . ,boot-mode) + (image-format . ,image-format) + (partition-scheme . ,partition-scheme) + (efi-size . ,efi-size) + (root-size . ,root-size) + (disk-capacity . ,disk-capacity) + (efi-partition-label . ,efi-partition-label) + (root-partition-label . ,root-partition-label) + (serial-console . ,serial-console) + (init-mode . ,(operating-system-init-mode os)))) + +(define* (operating-system-installer-image-spec os + #:key + (install-target-device "/dev/vtbd1") + (installer-host-name (string-append (operating-system-host-name os) + "-installer")) + (efi-size "64m") + (root-size "10g") + (disk-capacity #f) + (installer-efi-partition-label "efiboot") + (installer-root-partition-label "fruix-installer-root") + (target-efi-partition-label "efiboot") + (target-root-partition-label "fruix-root") + (serial-console "comconsole")) + (let* ((installer-os (installer-operating-system os + #:host-name installer-host-name + #:root-partition-label installer-root-partition-label)) + (target-install-spec (operating-system-install-spec os + #:target install-target-device + #:target-kind 'block-device + #:efi-size efi-size + #:root-size #f + #:disk-capacity #f + #:efi-partition-label target-efi-partition-label + #:root-partition-label target-root-partition-label + #:serial-console serial-console))) + `((installer-host-name . ,installer-host-name) + (install-target-device . ,install-target-device) + (installer-root-partition-label . ,installer-root-partition-label) + (installer-image . ,(operating-system-image-spec installer-os + #:efi-size efi-size + #:root-size root-size + #:disk-capacity disk-capacity + #:efi-partition-label installer-efi-partition-label + #:root-partition-label installer-root-partition-label + #:serial-console serial-console)) + (target-install . ,target-install-spec)))) + +(define image-builder-version "2") +(define install-builder-version "1") +(define installer-image-builder-version "1") + +(define (operating-system-install-metadata-object install-spec closure-path store-items) + `((install-version . ,install-builder-version) + (install-spec . ,install-spec) + (closure-path . ,closure-path) + (store-item-count . ,(length store-items)) + (store-items . ,store-items))) + +(define (render-installer-run-script store-dir plan-directory) + (let ((target-rootfs (string-append plan-directory "/target-rootfs")) + (store-items-file (string-append plan-directory "/store-items")) + (install-metadata-source (string-append plan-directory "/install.scm")) + (target-loader-efi (string-append plan-directory "/loader.efi")) + (state-file (string-append plan-directory "/state")) + (log-file "/var/log/fruix-installer.log") + (target-device-file (string-append plan-directory "/target-device")) + (efi-size-file (string-append plan-directory "/efi-size")) + (efi-label-file (string-append plan-directory "/efi-partition-label")) + (root-label-file (string-append plan-directory "/root-partition-label"))) + (string-append + "#!/bin/sh\n" + "set -eu\n" + "PATH=/sbin:/bin:/usr/sbin:/usr/bin:/usr/local/sbin:/usr/local/bin\n" + "umask 022\n" + "target_rootfs='" target-rootfs "'\n" + "store_items_file='" store-items-file "'\n" + "install_metadata_source='" install-metadata-source "'\n" + "target_loader_efi='" target-loader-efi "'\n" + "state_file='" state-file "'\n" + "log_file='" log-file "'\n" + "target_device=$(cat '" target-device-file "')\n" + "efi_size=$(cat '" efi-size-file "')\n" + "efi_partition_label=$(cat '" efi-label-file "')\n" + "root_partition_label=$(cat '" root-label-file "')\n" + "esp_device=\"${target_device}p1\"\n" + "root_device=\"${target_device}p2\"\n" + "mnt_root=/var/run/fruix-installer/target-root\n" + "mnt_esp=/var/run/fruix-installer/target-esp\n" + "write_state()\n" + "{\n" + " mkdir -p \"$(dirname \"$state_file\")\"\n" + " printf '%s\\n' \"$1\" >\"$state_file\"\n" + "}\n" + "cleanup()\n" + "{\n" + " umount \"$mnt_esp\" >/dev/null 2>&1 || true\n" + " umount \"$mnt_root\" >/dev/null 2>&1 || true\n" + "}\n" + "cleanup_and_record()\n" + "{\n" + " status=\"$1\"\n" + " if [ \"$status\" -ne 0 ]; then\n" + " echo \"fruix-installer:failed status=$status\"\n" + " write_state failed\n" + " fi\n" + " cleanup\n" + "}\n" + "trap 'status=$?; cleanup_and_record \"$status\"' EXIT\n" + "trap 'exit 1' INT TERM\n" + "mkdir -p \"$(dirname \"$log_file\")\" /var/run/fruix-installer\n" + "exec >>\"$log_file\" 2>&1\n" + "echo 'fruix-installer:start'\n" + "write_state starting\n" + "[ -e \"$target_device\" ] || { echo \"fruix-installer:error missing target device $target_device\"; exit 1; }\n" + "gpart destroy -F \"$target_device\" >/dev/null 2>&1 || true\n" + "gpart create -s gpt \"$target_device\"\n" + "gpart add -a 1m -s \"$efi_size\" -t efi -l \"$efi_partition_label\" \"$target_device\"\n" + "gpart add -a 1m -t freebsd-ufs -l \"$root_partition_label\" \"$target_device\"\n" + "newfs_msdos -L EFISYS \"$esp_device\"\n" + "newfs -U -L \"$root_partition_label\" \"$root_device\"\n" + "mkdir -p \"$mnt_root\" \"$mnt_esp\"\n" + "mount -t ufs \"$root_device\" \"$mnt_root\"\n" + "mount -t msdosfs \"$esp_device\" \"$mnt_esp\"\n" + "write_state copying-rootfs\n" + "(cd \"$target_rootfs\" && pax -rw -pe . \"$mnt_root\")\n" + "mkdir -p \"$mnt_root" store-dir "\"\n" + "write_state copying-store\n" + "while IFS= read -r item_base || [ -n \"$item_base\" ]; do\n" + " [ -n \"$item_base\" ] || continue\n" + " (cd '" store-dir "' && pax -rw -pe \"$item_base\" \"$mnt_root" store-dir "\")\n" + "done <\"$store_items_file\"\n" + "mkdir -p \"$mnt_root/var/lib/fruix\" \"$mnt_esp/EFI/BOOT\"\n" + "cp \"$target_loader_efi\" \"$mnt_esp/EFI/BOOT/BOOTX64.EFI\"\n" + "cp \"$install_metadata_source\" \"$mnt_root/var/lib/fruix/install.scm\"\n" + "sync\n" + "echo 'fruix-installer:done'\n" + "write_state done\n"))) + +(define (render-installer-rc-script plan-directory) + (string-append + "#!/bin/sh\n" + "# PROVIDE: fruix_installer\n" + "# REQUIRE: NETWORKING sshd fruix_shepherd\n" + "# KEYWORD: shutdown\n\n" + ". /etc/rc.subr\n\n" + "name=fruix_installer\n" + "rcvar=fruix_installer_enable\n" + ": ${fruix_installer_enable:=YES}\n" + "pidfile=/var/run/fruix-installer.pid\n" + "command=/usr/sbin/daemon\n" + "command_args='-c -f -p /var/run/fruix-installer.pid -o /var/log/fruix-installer-bootstrap.out /usr/local/libexec/fruix-installer-run'\n" + "start_cmd=fruix_installer_start\n" + "stop_cmd=fruix_installer_stop\n" + "status_cmd=fruix_installer_status\n\n" + "fruix_installer_start()\n" + "{\n" + " mkdir -p '" plan-directory "' /var/run\n" + " $command $command_args\n" + "}\n\n" + "fruix_installer_stop()\n" + "{\n" + " [ -f \"$pidfile\" ] && kill \"$(cat \"$pidfile\")\" >/dev/null 2>&1 || true\n" + " rm -f \"$pidfile\"\n" + " return 0\n" + "}\n\n" + "fruix_installer_status()\n" + "{\n" + " [ -f '" plan-directory "/state' ]\n" + "}\n\n" + "load_rc_config $name\n" + "run_rc_command \"$1\"\n")) + +(define (resize-gpt-image image disk-capacity) + (when disk-capacity + (run-command "truncate" "-s" disk-capacity image) + (let ((md (command-output "mdconfig" "-a" "-t" "vnode" "-f" image))) + (dynamic-wind + (lambda () #t) + (lambda () + (run-command "gpart" "recover" (string-append "/dev/" md))) + (lambda () + (run-command "mdconfig" "-d" "-u" (string-drop md 2))))))) + +(define* (install-operating-system os + #:key + target + (store-dir "/frx/store") + (guile-prefix "/tmp/guile-freebsd-validate-install") + (guile-extra-prefix "/tmp/guile-gnutls-freebsd-validate-install") + (shepherd-prefix "/tmp/shepherd-freebsd-validate-install") + (efi-size "64m") + (root-size #f) + (disk-capacity #f) + (efi-partition-label "efiboot") + (root-partition-label "fruix-root") + (serial-console "comconsole")) + (unless (and (string? target) (not (string-null? target))) + (error "install target must be a non-empty path" target)) + (let* ((closure (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 closure 'closure-path)) + (store-items (store-reference-closure (list closure-path))) + (target-kind (if (string-prefix? "/dev/" target) + 'block-device + 'raw-file)) + (install-spec (operating-system-install-spec os + #:target target + #:target-kind target-kind + #:efi-size efi-size + #:root-size root-size + #:disk-capacity disk-capacity + #:efi-partition-label efi-partition-label + #:root-partition-label root-partition-label + #:serial-console serial-console)) + (build-root (mktemp-directory "/tmp/fruix-system-install.XXXXXX")) + (rootfs (string-append build-root "/rootfs")) + (mnt-root (string-append build-root "/mnt-root")) + (mnt-esp (string-append build-root "/mnt-esp")) + (install-metadata-relative-path "/var/lib/fruix/install.scm") + (target-device #f) + (target-md #f) + (esp-device #f) + (root-device #f) + (root-mounted? #f) + (esp-mounted? #f)) + (dynamic-wind + (lambda () #t) + (lambda () + (populate-rootfs-from-closure os rootfs closure-path) + (mkdir-p mnt-root) + (mkdir-p mnt-esp) + (case target-kind + ((raw-file) + (unless disk-capacity + (error "raw-file install target requires --disk-capacity" target)) + (mkdir-p (dirname target)) + (delete-path-if-exists target) + (run-command "truncate" "-s" disk-capacity target) + (let ((md (command-output "mdconfig" "-a" "-t" "vnode" "-f" target))) + (set! target-md md) + (set! target-device (string-append "/dev/" md)))) + ((block-device) + (set! target-device target))) + (system* "sh" "-c" + (string-append "gpart destroy -F " target-device " >/dev/null 2>&1")) + (run-command "gpart" "create" "-s" "gpt" target-device) + (run-command "gpart" "add" "-a" "1m" "-s" efi-size + "-t" "efi" "-l" efi-partition-label target-device) + (if root-size + (run-command "gpart" "add" "-a" "1m" "-s" root-size + "-t" "freebsd-ufs" "-l" root-partition-label target-device) + (run-command "gpart" "add" "-a" "1m" + "-t" "freebsd-ufs" "-l" root-partition-label target-device)) + (set! esp-device (string-append target-device "p1")) + (set! root-device (string-append target-device "p2")) + (run-command "newfs_msdos" "-L" "EFISYS" esp-device) + (run-command "newfs" "-U" "-L" root-partition-label root-device) + (run-command "mount" "-t" "ufs" root-device mnt-root) + (set! root-mounted? #t) + (run-command "mount" "-t" "msdosfs" esp-device mnt-esp) + (set! esp-mounted? #t) + (copy-tree-contents rootfs mnt-root) + (copy-store-items-into-rootfs mnt-root store-dir store-items) + (mkdir-p (string-append mnt-esp "/EFI/BOOT")) + (copy-regular-file (string-append closure-path "/boot/loader.efi") + (string-append mnt-esp "/EFI/BOOT/BOOTX64.EFI")) + (let ((install-metadata-file (string-append mnt-root install-metadata-relative-path))) + (write-file install-metadata-file + (object->string + (operating-system-install-metadata-object install-spec closure-path store-items))) + (chmod install-metadata-file #o644)) + (run-command "sync") + `((target . ,target) + (target-kind . ,target-kind) + (target-device . ,target-device) + (esp-device . ,esp-device) + (root-device . ,root-device) + (install-spec . ,install-spec) + (install-metadata-path . ,install-metadata-relative-path) + (closure-path . ,closure-path) + (host-base-stores . ,(assoc-ref closure 'host-base-stores)) + (native-base-stores . ,(assoc-ref closure 'native-base-stores)) + (fruix-runtime-stores . ,(assoc-ref closure 'fruix-runtime-stores)) + (freebsd-base-file . ,(assoc-ref closure 'freebsd-base-file)) + (freebsd-source-file . ,(assoc-ref closure 'freebsd-source-file)) + (freebsd-source-materializations-file . ,(assoc-ref closure 'freebsd-source-materializations-file)) + (materialized-source-stores . ,(assoc-ref closure 'materialized-source-stores)) + (host-base-provenance-file . ,(assoc-ref closure 'host-base-provenance-file)) + (store-layout-file . ,(assoc-ref closure 'store-layout-file)) + (store-items . ,store-items))) + (lambda () + (when esp-mounted? + (system* "umount" mnt-esp) + (set! esp-mounted? #f)) + (when root-mounted? + (system* "umount" mnt-root) + (set! root-mounted? #f)) + (when target-md + (system* "mdconfig" "-d" "-u" (string-drop target-md 2)) + (set! target-md #f)) + (when (file-exists? build-root) + (delete-file-recursively build-root)))))) + +(define* (materialize-bhyve-image os + #:key + (store-dir "/frx/store") + (guile-prefix "/tmp/guile-freebsd-validate-install") + (guile-extra-prefix "/tmp/guile-gnutls-freebsd-validate-install") + (shepherd-prefix "/tmp/shepherd-freebsd-validate-install") + (efi-size "64m") + (root-size "256m") + (disk-capacity #f) + (efi-partition-label "efiboot") + (root-partition-label "fruix-root") + (serial-console "comconsole")) + (let* ((closure (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 closure 'closure-path)) + (image-spec (operating-system-image-spec os + #:efi-size efi-size + #:root-size root-size + #:disk-capacity disk-capacity + #:efi-partition-label efi-partition-label + #:root-partition-label root-partition-label + #:serial-console serial-console)) + (store-items (store-reference-closure (list closure-path))) + (manifest (string-append + "image-builder-version=\n" + image-builder-version + "\nimage-spec=\n" + (object->string image-spec) + "closure-path=\n" + closure-path + "\nstore-items=\n" + (string-join store-items "\n") + "\n")) + (hash (string-hash manifest)) + (image-store-path (string-append store-dir "/" hash "-fruix-bhyve-image-" + (operating-system-host-name os))) + (disk-image (string-append image-store-path "/disk.img")) + (esp-image (string-append image-store-path "/esp.img")) + (root-image (string-append image-store-path "/root.ufs"))) + (unless (file-exists? image-store-path) + (let* ((build-root (mktemp-directory "/tmp/fruix-bhyve-image-build.XXXXXX")) + (rootfs (string-append build-root "/rootfs")) + (image-rootfs (string-append build-root "/image-rootfs")) + (esp-stage (string-append build-root "/esp-stage")) + (temp-output (mktemp-directory (string-append store-dir "/.fruix-bhyve-image.XXXXXX"))) + (temp-disk (string-append build-root "/disk.img")) + (temp-esp (string-append build-root "/esp.img")) + (temp-root (string-append build-root "/root.ufs"))) + (dynamic-wind + (lambda () #t) + (lambda () + (materialize-rootfs os rootfs + #:store-dir store-dir + #:guile-prefix guile-prefix + #:guile-extra-prefix guile-extra-prefix + #:shepherd-prefix shepherd-prefix) + (copy-rootfs-for-image rootfs image-rootfs) + (copy-store-items-into-rootfs image-rootfs store-dir store-items) + (mkdir-p (string-append esp-stage "/EFI/BOOT")) + (copy-regular-file (string-append closure-path "/boot/loader.efi") + (string-append esp-stage "/EFI/BOOT/BOOTX64.EFI")) + (run-command "makefs" "-t" "ffs" "-T" "0" "-B" "little" + "-s" root-size + "-o" (string-append "label=" root-partition-label + ",version=2,bsize=32768,fsize=4096,density=16384") + temp-root image-rootfs) + (run-command "makefs" "-t" "msdos" "-T" "0" + "-o" "fat_type=32" + "-o" "sectors_per_cluster=1" + "-o" "volume_label=EFISYS" + "-o" "volume_id=305419896" + "-s" efi-size + temp-esp esp-stage) + (run-command "mkimg" "-s" "gpt" "-f" "raw" "-t" "0" + "-p" (string-append "efi/" efi-partition-label ":=" temp-esp) + "-p" (string-append "freebsd-ufs/" root-partition-label ":=" temp-root) + "-o" temp-disk) + (resize-gpt-image temp-disk disk-capacity) + (mkdir-p temp-output) + (copy-regular-file temp-disk (string-append temp-output "/disk.img")) + (copy-regular-file temp-esp (string-append temp-output "/esp.img")) + (copy-regular-file temp-root (string-append temp-output "/root.ufs")) + (write-file (string-append temp-output "/image-spec.scm") (object->string image-spec)) + (write-file (string-append temp-output "/closure-path") closure-path) + (write-file (string-append temp-output "/.references") (string-join store-items "\n")) + (write-file (string-append temp-output "/.fruix-package") manifest) + (chmod temp-output #o755) + (for-each (lambda (path) + (chmod path #o644)) + (list (string-append temp-output "/disk.img") + (string-append temp-output "/esp.img") + (string-append temp-output "/root.ufs") + (string-append temp-output "/image-spec.scm") + (string-append temp-output "/closure-path") + (string-append temp-output "/.references") + (string-append temp-output "/.fruix-package"))) + (rename-file temp-output image-store-path)) + (lambda () + (when (file-exists? build-root) + (delete-file-recursively build-root)))))) + `((image-store-path . ,image-store-path) + (disk-image . ,disk-image) + (esp-image . ,esp-image) + (root-image . ,root-image) + (closure-path . ,closure-path) + (host-base-stores . ,(assoc-ref closure 'host-base-stores)) + (native-base-stores . ,(assoc-ref closure 'native-base-stores)) + (fruix-runtime-stores . ,(assoc-ref closure 'fruix-runtime-stores)) + (freebsd-base-file . ,(assoc-ref closure 'freebsd-base-file)) + (freebsd-source-file . ,(assoc-ref closure 'freebsd-source-file)) + (freebsd-source-materializations-file . ,(assoc-ref closure 'freebsd-source-materializations-file)) + (materialized-source-stores . ,(assoc-ref closure 'materialized-source-stores)) + (host-base-provenance-file . ,(assoc-ref closure 'host-base-provenance-file)) + (store-layout-file . ,(assoc-ref closure 'store-layout-file)) + (image-spec . ,image-spec) + (store-items . ,store-items)))) + +(define* (materialize-installer-image os + #:key + (store-dir "/frx/store") + (guile-prefix "/tmp/guile-freebsd-validate-install") + (guile-extra-prefix "/tmp/guile-gnutls-freebsd-validate-install") + (shepherd-prefix "/tmp/shepherd-freebsd-validate-install") + (install-target-device "/dev/vtbd1") + (efi-size "64m") + (root-size "10g") + (disk-capacity #f) + (installer-host-name (string-append (operating-system-host-name os) + "-installer")) + (installer-efi-partition-label "efiboot") + (installer-root-partition-label "fruix-installer-root") + (target-efi-partition-label "efiboot") + (target-root-partition-label "fruix-root") + (serial-console "comconsole")) + (let* ((installer-os (installer-operating-system os + #:host-name installer-host-name + #:root-partition-label installer-root-partition-label)) + (target-closure (materialize-operating-system os + #:store-dir store-dir + #:guile-prefix guile-prefix + #:guile-extra-prefix guile-extra-prefix + #:shepherd-prefix shepherd-prefix)) + (installer-closure (materialize-operating-system installer-os + #:store-dir store-dir + #:guile-prefix guile-prefix + #:guile-extra-prefix guile-extra-prefix + #:shepherd-prefix shepherd-prefix)) + (target-closure-path (assoc-ref target-closure 'closure-path)) + (installer-closure-path (assoc-ref installer-closure 'closure-path)) + (target-store-items (store-reference-closure (list target-closure-path))) + (installer-store-items (store-reference-closure (list installer-closure-path))) + (combined-store-items (delete-duplicates (append installer-store-items target-store-items))) + (installer-image-spec (operating-system-installer-image-spec os + #:install-target-device install-target-device + #:installer-host-name installer-host-name + #:efi-size efi-size + #:root-size root-size + #:disk-capacity disk-capacity + #:installer-efi-partition-label installer-efi-partition-label + #:installer-root-partition-label installer-root-partition-label + #:target-efi-partition-label target-efi-partition-label + #:target-root-partition-label target-root-partition-label + #:serial-console serial-console)) + (image-spec (assoc-ref installer-image-spec 'installer-image)) + (target-install-spec (assoc-ref installer-image-spec 'target-install)) + (install-metadata (operating-system-install-metadata-object target-install-spec + target-closure-path + target-store-items)) + (installer-plan-directory "/var/lib/fruix/installer") + (installer-state-path (string-append installer-plan-directory "/state")) + (installer-log-path "/var/log/fruix-installer.log") + (manifest (string-append + "installer-image-builder-version=\n" + installer-image-builder-version + "\ninstaller-image-spec=\n" + (object->string installer-image-spec) + "installer-closure-path=\n" + installer-closure-path + "\ntarget-closure-path=\n" + target-closure-path + "\ncombined-store-items=\n" + (string-join combined-store-items "\n") + "\ntarget-store-items=\n" + (string-join target-store-items "\n") + "\ninstall-metadata=\n" + (object->string install-metadata) + "\n")) + (hash (string-hash manifest)) + (image-store-path (string-append store-dir "/" hash "-fruix-installer-image-" + (operating-system-host-name installer-os))) + (disk-image (string-append image-store-path "/disk.img")) + (esp-image (string-append image-store-path "/esp.img")) + (root-image (string-append image-store-path "/root.ufs"))) + (unless (file-exists? image-store-path) + (let* ((build-root (mktemp-directory "/tmp/fruix-installer-image-build.XXXXXX")) + (installer-rootfs (string-append build-root "/installer-rootfs")) + (target-rootfs (string-append build-root "/target-rootfs")) + (image-rootfs (string-append build-root "/image-rootfs")) + (esp-stage (string-append build-root "/esp-stage")) + (temp-output (mktemp-directory (string-append store-dir "/.fruix-installer-image.XXXXXX"))) + (temp-disk (string-append build-root "/disk.img")) + (temp-esp (string-append build-root "/esp.img")) + (temp-root (string-append build-root "/root.ufs")) + (plan-root (string-append image-rootfs installer-plan-directory))) + (dynamic-wind + (lambda () #t) + (lambda () + (populate-rootfs-from-closure installer-os installer-rootfs installer-closure-path) + (populate-rootfs-from-closure os target-rootfs target-closure-path) + (copy-rootfs-for-image installer-rootfs image-rootfs) + (mkdir-p plan-root) + (mkdir-p (string-append image-rootfs "/usr/local/libexec")) + (mkdir-p (string-append image-rootfs "/usr/local/etc/rc.d")) + (mkdir-p (string-append plan-root "/target-rootfs")) + (copy-tree-contents target-rootfs (string-append plan-root "/target-rootfs")) + (copy-store-items-into-rootfs image-rootfs store-dir combined-store-items) + (write-file (string-append plan-root "/store-items") + (string-append (string-join (map path-basename target-store-items) "\n") "\n")) + (write-file (string-append plan-root "/install.scm") + (object->string install-metadata)) + (copy-regular-file (string-append target-closure-path "/boot/loader.efi") + (string-append plan-root "/loader.efi")) + (write-file (string-append plan-root "/target-device") + (string-append install-target-device "\n")) + (write-file (string-append plan-root "/efi-size") + (string-append efi-size "\n")) + (write-file (string-append plan-root "/efi-partition-label") + (string-append target-efi-partition-label "\n")) + (write-file (string-append plan-root "/root-partition-label") + (string-append target-root-partition-label "\n")) + (write-file (string-append plan-root "/state") "pending\n") + (write-file (string-append image-rootfs "/usr/local/libexec/fruix-installer-run") + (render-installer-run-script store-dir installer-plan-directory)) + (write-file (string-append image-rootfs "/usr/local/etc/rc.d/fruix-installer") + (render-installer-rc-script installer-plan-directory)) + (chmod (string-append image-rootfs "/usr/local/libexec/fruix-installer-run") #o555) + (chmod (string-append image-rootfs "/usr/local/etc/rc.d/fruix-installer") #o555) + (mkdir-p (string-append esp-stage "/EFI/BOOT")) + (copy-regular-file (string-append installer-closure-path "/boot/loader.efi") + (string-append esp-stage "/EFI/BOOT/BOOTX64.EFI")) + (run-command "makefs" "-t" "ffs" "-T" "0" "-B" "little" + "-s" root-size + "-o" (string-append "label=" installer-root-partition-label + ",version=2,bsize=32768,fsize=4096,density=16384") + temp-root image-rootfs) + (run-command "makefs" "-t" "msdos" "-T" "0" + "-o" "fat_type=32" + "-o" "sectors_per_cluster=1" + "-o" "volume_label=EFISYS" + "-o" "volume_id=305419896" + "-s" efi-size + temp-esp esp-stage) + (run-command "mkimg" "-s" "gpt" "-f" "raw" "-t" "0" + "-p" (string-append "efi/" installer-efi-partition-label ":=" temp-esp) + "-p" (string-append "freebsd-ufs/" installer-root-partition-label ":=" temp-root) + "-o" temp-disk) + (resize-gpt-image temp-disk disk-capacity) + (mkdir-p temp-output) + (copy-regular-file temp-disk (string-append temp-output "/disk.img")) + (copy-regular-file temp-esp (string-append temp-output "/esp.img")) + (copy-regular-file temp-root (string-append temp-output "/root.ufs")) + (write-file (string-append temp-output "/installer-image-spec.scm") + (object->string installer-image-spec)) + (write-file (string-append temp-output "/installer-closure-path") installer-closure-path) + (write-file (string-append temp-output "/target-closure-path") target-closure-path) + (write-file (string-append temp-output "/.references") + (string-join combined-store-items "\n")) + (write-file (string-append temp-output "/.fruix-package") manifest) + (chmod temp-output #o755) + (for-each (lambda (path) + (chmod path #o644)) + (list (string-append temp-output "/disk.img") + (string-append temp-output "/esp.img") + (string-append temp-output "/root.ufs") + (string-append temp-output "/installer-image-spec.scm") + (string-append temp-output "/installer-closure-path") + (string-append temp-output "/target-closure-path") + (string-append temp-output "/.references") + (string-append temp-output "/.fruix-package"))) + (rename-file temp-output image-store-path)) + (lambda () + (when (file-exists? build-root) + (delete-file-recursively build-root)))))) + `((image-store-path . ,image-store-path) + (disk-image . ,disk-image) + (esp-image . ,esp-image) + (root-image . ,root-image) + (installer-closure-path . ,installer-closure-path) + (target-closure-path . ,target-closure-path) + (closure-path . ,installer-closure-path) + (image-spec . ,image-spec) + (installer-image-spec . ,installer-image-spec) + (install-spec . ,target-install-spec) + (installer-state-path . ,installer-state-path) + (installer-log-path . ,installer-log-path) + (install-target-device . ,install-target-device) + (host-base-stores . ,(assoc-ref target-closure 'host-base-stores)) + (native-base-stores . ,(assoc-ref target-closure 'native-base-stores)) + (fruix-runtime-stores . ,(assoc-ref target-closure 'fruix-runtime-stores)) + (freebsd-base-file . ,(assoc-ref target-closure 'freebsd-base-file)) + (freebsd-source-file . ,(assoc-ref target-closure 'freebsd-source-file)) + (freebsd-source-materializations-file . ,(assoc-ref target-closure 'freebsd-source-materializations-file)) + (materialized-source-stores . ,(assoc-ref target-closure 'materialized-source-stores)) + (host-base-provenance-file . ,(assoc-ref target-closure 'host-base-provenance-file)) + (store-layout-file . ,(assoc-ref target-closure 'store-layout-file)) + (store-items . ,combined-store-items) + (target-store-items . ,target-store-items) + (installer-store-items . ,installer-store-items)))) diff --git a/modules/fruix/system/freebsd/model.scm b/modules/fruix/system/freebsd/model.scm new file mode 100644 index 0000000..c3db02c --- /dev/null +++ b/modules/fruix/system/freebsd/model.scm @@ -0,0 +1,334 @@ +(define-module (fruix system freebsd model) + #:use-module (fruix packages freebsd) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-13) + #:export (user-group + user-group? + user-group-name + user-group-gid + user-group-system? + user-account + user-account? + user-account-name + user-account-uid + user-account-group + user-account-supplementary-groups + user-account-comment + user-account-home + user-account-shell + user-account-system? + file-system + file-system? + file-system-device + file-system-mount-point + file-system-type + file-system-options + file-system-needed-for-boot? + operating-system + operating-system? + operating-system-host-name + operating-system-freebsd-base + operating-system-kernel + operating-system-bootloader + operating-system-base-packages + operating-system-users + operating-system-groups + operating-system-file-systems + operating-system-services + operating-system-loader-entries + operating-system-rc-conf-entries + operating-system-init-mode + operating-system-ready-marker + operating-system-root-authorized-keys + default-minimal-operating-system + freebsd-source-spec + freebsd-base-spec + validate-freebsd-source + validate-operating-system + pid1-init-mode? + effective-loader-entries + rc-conf-entry-value + sshd-enabled? + operating-system-generated-file-names + operating-system-closure-spec)) + +(define-record-type + (make-user-group name gid system?) + user-group? + (name user-group-name) + (gid user-group-gid) + (system? user-group-system?)) + +(define* (user-group #:key name gid (system? #t)) + (make-user-group name gid system?)) + +(define-record-type + (make-user-account name uid group supplementary-groups comment home shell system?) + user-account? + (name user-account-name) + (uid user-account-uid) + (group user-account-group) + (supplementary-groups user-account-supplementary-groups) + (comment user-account-comment) + (home user-account-home) + (shell user-account-shell) + (system? user-account-system?)) + +(define* (user-account #:key name uid group (supplementary-groups '()) + (comment "Fruix user") (home "/nonexistent") + (shell "/usr/sbin/nologin") (system? #t)) + (make-user-account name uid group supplementary-groups comment home shell system?)) + +(define-record-type + (make-file-system device mount-point type options needed-for-boot?) + file-system? + (device file-system-device) + (mount-point file-system-mount-point) + (type file-system-type) + (options file-system-options) + (needed-for-boot? file-system-needed-for-boot?)) + +(define* (file-system #:key device mount-point type (options "rw") + (needed-for-boot? #f)) + (make-file-system device mount-point type options needed-for-boot?)) + +(define-record-type + (make-operating-system host-name freebsd-base kernel bootloader base-packages users groups + file-systems services loader-entries rc-conf-entries + init-mode ready-marker root-authorized-keys) + operating-system? + (host-name operating-system-host-name) + (freebsd-base operating-system-freebsd-base) + (kernel operating-system-kernel) + (bootloader operating-system-bootloader) + (base-packages operating-system-base-packages) + (users operating-system-users) + (groups operating-system-groups) + (file-systems operating-system-file-systems) + (services operating-system-services) + (loader-entries operating-system-loader-entries) + (rc-conf-entries operating-system-rc-conf-entries) + (init-mode operating-system-init-mode) + (ready-marker operating-system-ready-marker) + (root-authorized-keys operating-system-root-authorized-keys)) + +(define* (operating-system #:key + (host-name "fruix-freebsd") + (freebsd-base %default-freebsd-base) + (kernel freebsd-kernel) + (bootloader freebsd-bootloader) + (base-packages %freebsd-system-packages) + (users (list (user-account #:name "root" + #:uid 0 + #:group "wheel" + #:comment "Charlie &" + #:home "/root" + #:shell "/bin/sh" + #:system? #t) + (user-account #:name "operator" + #:uid 1000 + #:group "operator" + #:supplementary-groups '("wheel") + #:comment "Fruix Operator" + #:home "/home/operator" + #:shell "/bin/sh" + #:system? #f))) + (groups (list (user-group #:name "wheel" #:gid 0 #:system? #t) + (user-group #:name "operator" #:gid 1000 #:system? #f))) + (file-systems (list (file-system #:device "/dev/ufs/fruix-root" + #:mount-point "/" + #:type "ufs" + #:options "rw" + #:needed-for-boot? #t) + (file-system #:device "devfs" + #:mount-point "/dev" + #:type "devfs" + #:options "rw" + #:needed-for-boot? #t) + (file-system #:device "tmpfs" + #:mount-point "/tmp" + #:type "tmpfs" + #:options "rw,size=64m" + #:needed-for-boot? #f))) + (services '(shepherd ready-marker)) + (loader-entries '(("autoboot_delay" . "1") + ("console" . "comconsole"))) + (rc-conf-entries '(("clear_tmp_enable" . "YES") + ("sendmail_enable" . "NONE") + ("sshd_enable" . "NO"))) + (init-mode 'freebsd-init+rc.d-shepherd) + (ready-marker "/var/lib/fruix/ready") + (root-authorized-keys '())) + (make-operating-system host-name freebsd-base kernel bootloader base-packages users groups + file-systems services loader-entries rc-conf-entries + init-mode ready-marker root-authorized-keys)) + +(define default-minimal-operating-system (operating-system)) + +(define (package-names packages) + (map freebsd-package-name packages)) + +(define (freebsd-source-spec source) + `((name . ,(freebsd-source-name source)) + (kind . ,(freebsd-source-kind source)) + (url . ,(freebsd-source-url source)) + (path . ,(freebsd-source-path source)) + (ref . ,(freebsd-source-ref source)) + (commit . ,(freebsd-source-commit source)) + (sha256 . ,(freebsd-source-sha256 source)))) + +(define (freebsd-base-spec base) + `((name . ,(freebsd-base-name base)) + (version-label . ,(freebsd-base-version-label base)) + (release . ,(freebsd-base-release base)) + (branch . ,(freebsd-base-branch base)) + (source-root . ,(freebsd-base-source-root base)) + (source . ,(freebsd-source-spec (freebsd-base-source base))) + (target . ,(freebsd-base-target base)) + (target-arch . ,(freebsd-base-target-arch base)) + (kernconf . ,(freebsd-base-kernconf base)) + (make-flags . ,(freebsd-base-make-flags base)))) + + +(define (duplicate-elements values) + (let loop ((rest values) (seen '()) (duplicates '())) + (match rest + (() (reverse duplicates)) + ((head . tail) + (if (member head seen) + (loop tail seen (if (member head duplicates) duplicates (cons head duplicates))) + (loop tail (cons head seen) duplicates)))))) + +(define (non-empty-string? value) + (and (string? value) + (not (string-null? value)))) + +(define (validate-freebsd-source source) + (unless (freebsd-source? source) + (error "freebsd base source must be a record")) + (let ((kind (freebsd-source-kind source))) + (unless (member kind '(local-tree git src-txz)) + (error "unsupported freebsd source kind" kind)) + (case kind + ((local-tree) + (unless (non-empty-string? (freebsd-source-path source)) + (error "local-tree freebsd source must declare a path" source))) + ((git) + (unless (non-empty-string? (freebsd-source-url source)) + (error "git freebsd source must declare a URL" source)) + (unless (or (non-empty-string? (freebsd-source-ref source)) + (non-empty-string? (freebsd-source-commit source))) + (error "git freebsd source must declare a ref or commit" source))) + ((src-txz) + (unless (non-empty-string? (freebsd-source-url source)) + (error "src-txz freebsd source must declare a URL" source)) + (unless (non-empty-string? (freebsd-source-sha256 source)) + (error "src-txz freebsd source must declare a sha256" source))))) + #t) + +(define (validate-operating-system os) + (let* ((host-name (operating-system-host-name os)) + (base (operating-system-freebsd-base os)) + (users (operating-system-users os)) + (groups (operating-system-groups os)) + (file-systems (operating-system-file-systems os)) + (user-names (map user-account-name users)) + (group-names (map user-group-name groups)) + (mount-points (map file-system-mount-point file-systems)) + (init-mode (operating-system-init-mode os))) + (when (string-null? host-name) + (error "operating-system host-name must not be empty")) + (unless (freebsd-base? base) + (error "operating-system freebsd-base must be a record")) + (validate-freebsd-source (freebsd-base-source base)) + (let ((dups (duplicate-elements user-names))) + (unless (null? dups) + (error "duplicate user names in operating-system" dups))) + (let ((dups (duplicate-elements group-names))) + (unless (null? dups) + (error "duplicate group names in operating-system" dups))) + (unless (member "/" mount-points) + (error "operating-system must declare a root file-system")) + (unless (member "root" user-names) + (error "operating-system must declare a root user")) + (unless (member "wheel" group-names) + (error "operating-system must declare a wheel group")) + (unless (member init-mode '(freebsd-init+rc.d-shepherd shepherd-pid1)) + (error "unsupported operating-system init-mode" init-mode)) + #t)) + +(define (pid1-init-mode? os) + (eq? (operating-system-init-mode os) 'shepherd-pid1)) + +(define (effective-loader-entries os) + (append (if (pid1-init-mode? os) + '(("init_exec" . "/run/current-system/boot/fruix-pid1")) + '()) + (operating-system-loader-entries os))) + +(define (rc-conf-entry-value os key) + (let ((entry (assoc key (operating-system-rc-conf-entries os)))) + (and entry (cdr entry)))) + +(define (sshd-enabled? os) + (let ((value (rc-conf-entry-value os "sshd_enable"))) + (and value + (member (string-upcase value) '("YES" "TRUE" "1"))))) + + +(define (operating-system-generated-file-names os) + (append + '("boot/loader.conf" + "etc/rc.conf" + "etc/fstab" + "etc/hosts" + "etc/passwd" + "etc/master.passwd" + "etc/group" + "etc/login.conf" + "etc/shells" + "etc/motd" + "etc/ttys" + "metadata/freebsd-base.scm" + "metadata/host-base-provenance.scm" + "metadata/store-layout.scm" + "activate" + "shepherd/init.scm") + (if (pid1-init-mode? os) + '("boot/fruix-pid1") + '()) + (if (sshd-enabled? os) + '("etc/ssh/sshd_config") + '()) + (if (null? (operating-system-root-authorized-keys os)) + '() + '("root/.ssh/authorized_keys")))) + + +(define (operating-system-closure-spec os) + (validate-operating-system os) + `((host-name . ,(operating-system-host-name os)) + (freebsd-base . ,(freebsd-base-spec (operating-system-freebsd-base os))) + (kernel-package . ,(freebsd-package-name (operating-system-kernel os))) + (bootloader-package . ,(freebsd-package-name (operating-system-bootloader os))) + (base-package-count . ,(length (operating-system-base-packages os))) + (base-packages . ,(package-names (operating-system-base-packages os))) + (user-count . ,(length (operating-system-users os))) + (users . ,(map user-account-name (operating-system-users os))) + (group-count . ,(length (operating-system-groups os))) + (groups . ,(map user-group-name (operating-system-groups os))) + (file-system-count . ,(length (operating-system-file-systems os))) + (file-systems . ,(map (lambda (fs) + `((device . ,(file-system-device fs)) + (mount-point . ,(file-system-mount-point fs)) + (type . ,(file-system-type fs)) + (options . ,(file-system-options fs)) + (needed-for-boot? . ,(file-system-needed-for-boot? fs)))) + (operating-system-file-systems os))) + (services . ,(operating-system-services os)) + (generated-files . ,(operating-system-generated-file-names os)) + (init-mode . ,(operating-system-init-mode os)) + (ready-marker . ,(operating-system-ready-marker os)))) + diff --git a/modules/fruix/system/freebsd/render.scm b/modules/fruix/system/freebsd/render.scm new file mode 100644 index 0000000..130e408 --- /dev/null +++ b/modules/fruix/system/freebsd/render.scm @@ -0,0 +1,499 @@ +(define-module (fruix system freebsd render) + #:use-module (fruix system freebsd model) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-13) + #:export (operating-system-generated-files + render-activation-rc-script + render-rc-script)) + +(define (render-loader-conf os) + (string-append + (string-join (map (lambda (entry) + (format #f "~a=\"~a\"" (car entry) (cdr entry))) + (effective-loader-entries os)) + "\n") + "\n")) + +(define (render-rc.conf os) + (let* ((entries (append `(("hostname" . ,(operating-system-host-name os)) + ("fruix_activate_enable" . "YES") + ("fruix_shepherd_enable" . "YES")) + (operating-system-rc-conf-entries os)))) + (string-append + (string-join (map (lambda (entry) + (format #f "~a=\"~a\"" (car entry) (cdr entry))) + entries) + "\n") + "\n"))) + +(define (group-name->gid groups name) + (let ((group (find (lambda (item) + (string=? (user-group-name item) name)) + groups))) + (and group (user-group-gid group)))) + +(define (render-passwd os) + (let ((groups (operating-system-groups os))) + (string-append + (string-join + (map (lambda (account) + (format #f "~a:*:~a:~a:~a:~a:~a" + (user-account-name account) + (user-account-uid account) + (or (group-name->gid groups (user-account-group account)) + (error "unknown primary group" (user-account-group account))) + (user-account-comment account) + (user-account-home account) + (user-account-shell account))) + (operating-system-users os)) + "\n") + "\n"))) + +(define (render-master-passwd os) + (let ((groups (operating-system-groups os))) + (string-append + (string-join + (map (lambda (account) + (format #f "~a:*:~a:~a::0:0:~a:~a:~a" + (user-account-name account) + (user-account-uid account) + (or (group-name->gid groups (user-account-group account)) + (error "unknown primary group" (user-account-group account))) + (user-account-comment account) + (user-account-home account) + (user-account-shell account))) + (operating-system-users os)) + "\n") + "\n"))) + +(define (render-group os) + (let ((users (operating-system-users os))) + (string-append + (string-join + (map (lambda (group) + (let ((members (filter-map (lambda (account) + (and (member (user-group-name group) + (user-account-supplementary-groups account)) + (user-account-name account))) + users))) + (format #f "~a:*:~a:~a" + (user-group-name group) + (user-group-gid group) + (string-join members ",")))) + (operating-system-groups os)) + "\n") + "\n"))) + +(define (fstab-fsck-fields fs) + (if (string=? (file-system-type fs) "ufs") + (if (string=? (file-system-mount-point fs) "/") + '(1 1) + '(2 2)) + '(0 0))) + +(define (render-fstab os) + (string-append + (string-join + (map (lambda (fs) + (let ((checks (fstab-fsck-fields fs))) + (format #f "~a\t~a\t~a\t~a\t~a\t~a" + (file-system-device fs) + (file-system-mount-point fs) + (file-system-type fs) + (file-system-options fs) + (first checks) + (second checks)))) + (operating-system-file-systems os)) + "\n") + "\n")) + +(define (render-hosts os) + (string-append + "127.0.0.1\tlocalhost " (operating-system-host-name os) "\n" + "::1\tlocalhost\n")) + +(define (render-shells os) + (let ((shells (delete-duplicates (map user-account-shell (operating-system-users os))))) + (string-append (string-join shells "\n") "\n"))) + +(define (render-motd os) + (string-append "Welcome to Fruix on FreeBSD (" (operating-system-host-name os) ")\n")) + +(define (render-login-conf) + (string-append + "default:\\\n" + "\t:path=/sbin /bin /usr/sbin /usr/bin /usr/local/sbin /usr/local/bin:\\\n" + "\t:umask=022:\\\n" + "\t:charset=UTF-8:\\\n" + "\t:lang=C.UTF-8:\n" + "daemon:\\\n" + "\t:path=/sbin /bin /usr/sbin /usr/bin /usr/local/sbin /usr/local/bin:\\\n" + "\t:tc=default:\n" + "root:\\\n" + "\t:ignorenologin:\\\n" + "\t:tc=default:\n")) + +(define (render-ttys) + (string-append + "console\tnone\tunknown\toff secure\n" + "ttyu0\tnone\tvt100\toff secure\n" + "xc0\tnone\txterm\toff secure\n")) + +(define (render-root-authorized-keys os) + (if (null? (operating-system-root-authorized-keys os)) + "" + (string-append + (string-join (operating-system-root-authorized-keys os) "\n") + "\n"))) + +(define (render-sshd-config os) + (string-append + "Port 22\n" + "PermitRootLogin yes\n" + "PasswordAuthentication no\n" + "KbdInteractiveAuthentication no\n" + "ChallengeResponseAuthentication no\n" + "UsePAM no\n" + "PubkeyAuthentication yes\n" + "AuthorizedKeysFile .ssh/authorized_keys\n" + "PidFile /var/run/sshd.pid\n" + "UseDNS no\n")) + +(define* (render-activation-script os #:key guile-store guile-extra-store shepherd-store) + (let* ((users (operating-system-users os)) + (groups (operating-system-groups os)) + (home-setup + (string-join + (map (lambda (account) + (let ((name (user-account-name account)) + (uid (user-account-uid account)) + (gid (or (group-name->gid groups (user-account-group account)) + (error "unknown primary group" (user-account-group account)))) + (home (user-account-home account)) + (system? (user-account-system? account))) + (string-append + "mkdir -p " home "\n" + (if (or (string=? name "root") system?) + "" + (format #f "if [ -x /usr/sbin/chown ]; then /usr/sbin/chown ~a:~a ~a 2>/dev/null || true; fi\n" + uid gid home))))) + users) + "")) + (refresh-db-input-files + (string-join + (map (lambda (entry) + (match entry + ((name mode) + (string-append + "if [ -f /run/current-system/etc/" name " ]; then rm -f /etc/" name "; cp /run/current-system/etc/" name " /etc/" name "; chmod " mode " /etc/" name "; fi\n")))) + '(("passwd" "0644") + ("master.passwd" "0600") + ("group" "0644") + ("login.conf" "0644"))) + "")) + (ssh-section + (string-append + "mkdir -p /var/empty /etc/ssh /root/.ssh\n" + "chmod 700 /root/.ssh\n" + (if (null? (operating-system-root-authorized-keys os)) + "" + "if [ -f /run/current-system/root/.ssh/authorized_keys ]; then cp /run/current-system/root/.ssh/authorized_keys /root/.ssh/authorized_keys; chmod 600 /root/.ssh/authorized_keys; fi\n") + (if (sshd-enabled? os) + "if [ -x /usr/bin/ssh-keygen ]; then /usr/bin/ssh-keygen -A; fi\n" + "")))) + (string-append + "#!/bin/sh\n" + "set -eu\n" + "logfile=/var/log/fruix-activate.log\n" + "mkdir -p /var/cron /var/db /var/lib/fruix /var/log /var/run /root /home /tmp\n" + ": >> \"$logfile\"\n" + "trap 'status=$?; echo \"fruix-activate:exit status=$status\" >> \"$logfile\"' EXIT\n" + "echo \"fruix-activate:start\" >> \"$logfile\"\n" + "chmod 1777 /tmp\n" + refresh-db-input-files + "if [ -x /usr/bin/cap_mkdb ] && [ -f /etc/login.conf ]; then\n" + " if /usr/bin/cap_mkdb /etc/login.conf; then echo \"fruix-activate:cap_mkdb=ok\" >> \"$logfile\"; else echo \"fruix-activate:cap_mkdb=failed\" >> \"$logfile\"; fi\n" + "fi\n" + "if [ -x /usr/sbin/pwd_mkdb ] && [ -f /etc/master.passwd ]; then\n" + " if /usr/sbin/pwd_mkdb -p /etc/master.passwd; then echo \"fruix-activate:pwd_mkdb=ok\" >> \"$logfile\"; else echo \"fruix-activate:pwd_mkdb=failed\" >> \"$logfile\"; fi\n" + "fi\n" + home-setup + ssh-section + "echo \"fruix-activate:done\" >> \"$logfile\"\n"))) + +(define (pid1-mount-commands os) + (string-join + (filter-map (lambda (fs) + (and (not (string=? "/" (file-system-mount-point fs))) + (string-append + "mkdir -p '" (file-system-mount-point fs) "'\n" + "/sbin/mount -t '" (file-system-type fs) + "' -o '" (file-system-options fs) + "' '" (file-system-device fs) + "' '" (file-system-mount-point fs) + "' >/dev/null 2>&1 || true\n"))) + (operating-system-file-systems os)) + "")) + +(define (render-pid1-script os shepherd-store guile-store guile-extra-store) + (let ((ld-library-path (string-append guile-extra-store "/lib:" + guile-store "/lib:/usr/local/lib")) + (guile-system-path + (string-append guile-store "/share/guile/3.0:" + guile-store "/share/guile/site/3.0:" + guile-store "/share/guile/site:" + guile-store "/share/guile")) + (guile-load-path (string-append shepherd-store "/share/guile/site/3.0:" + guile-extra-store "/share/guile/site/3.0")) + (guile-system-compiled-path + (string-append guile-store "/lib/guile/3.0/ccache:" + guile-store "/lib/guile/3.0/site-ccache")) + (guile-load-compiled-path + (string-append shepherd-store "/lib/guile/3.0/site-ccache:" + guile-extra-store "/lib/guile/3.0/site-ccache")) + (guile-system-extensions-path (string-append guile-store "/lib/guile/3.0/extensions")) + (guile-extensions-path (string-append guile-extra-store "/lib/guile/3.0/extensions"))) + (string-append + "#!/bin/sh\n" + "set -eu\n" + "PATH=/sbin:/bin:/usr/sbin:/usr/bin:/usr/local/sbin:/usr/local/bin\n" + "/sbin/mount -u -o rw / >/dev/null 2>&1 || true\n" + (pid1-mount-commands os) + "/bin/hostname '" (operating-system-host-name os) "' >/dev/null 2>&1 || true\n" + "/run/current-system/activate\n" + "export GUILE_AUTO_COMPILE=0\n" + "export LANG='C.UTF-8'\n" + "export LC_ALL='C.UTF-8'\n" + "export LD_LIBRARY_PATH='" ld-library-path "'\n" + "export GUILE_SYSTEM_PATH='" guile-system-path "'\n" + "export GUILE_LOAD_PATH='" guile-load-path "'\n" + "export GUILE_SYSTEM_COMPILED_PATH='" guile-system-compiled-path "'\n" + "export GUILE_LOAD_COMPILED_PATH='" guile-load-compiled-path "'\n" + "export GUILE_SYSTEM_EXTENSIONS_PATH='" guile-system-extensions-path "'\n" + "export GUILE_EXTENSIONS_PATH='" guile-extensions-path "'\n" + "exec " guile-store "/bin/guile --no-auto-compile " shepherd-store "/bin/shepherd -I -s /var/run/shepherd.sock -c /run/current-system/shepherd/init.scm --pid=/var/run/shepherd.pid -l /var/log/shepherd.log\n"))) + +(define (render-shepherd-config os) + (let* ((ready-marker (operating-system-ready-marker os)) + (pid1? (pid1-init-mode? os)) + (start-sshd? (and pid1? (or (sshd-enabled? os) + (member 'sshd (operating-system-services os))))) + (ready-requirements (if start-sshd? + "'(fruix-logger sshd)" + "'(fruix-logger)")) + (pid1-helpers + (if pid1? + (string-append + "(define (run-command program . args)\n" + " (let ((status (apply system* program args)))\n" + " (unless (zero? status)\n" + " (error \"command failed\" (cons program args) status))\n" + " #t))\n\n" + "(define* (freebsd-rc-service provision script-name\n" + " #:key\n" + " (requirement '())\n" + " (documentation\n" + " \"Manage a FreeBSD rc.d service through 'service'.\"))\n" + " (service provision\n" + " #:documentation documentation\n" + " #:requirement requirement\n" + " #:start (lambda _\n" + " (run-command \"/usr/sbin/service\" script-name \"onestart\")\n" + " #t)\n" + " #:stop (lambda _\n" + " (run-command \"/usr/sbin/service\" script-name \"onestop\")\n" + " #f)\n" + " #:respawn? #f))\n\n") + "")) + (pid1-services + (if pid1? + (string-append + (if start-sshd? + " (freebsd-rc-service '(netif) \"netif\"\n" + "") + (if start-sshd? + " #:requirement '(fruix-logger)\n" + "") + (if start-sshd? + " #:documentation \"Bring up FreeBSD networking from rc.conf.\")\n" + "") + (if start-sshd? + " (freebsd-rc-service '(sshd) \"sshd\"\n" + "") + (if start-sshd? + " #:requirement '(netif)\n" + "") + (if start-sshd? + " #:documentation \"Start OpenSSH under Shepherd PID 1.\")\n" + "")) + ""))) + (string-append + "(use-modules (shepherd service)\n" + " (ice-9 ftw)\n" + " (ice-9 popen))\n\n" + "(define ready-marker \"" ready-marker "\")\n\n" + "(define (mkdir-p* dir)\n" + " (unless (or (string=? dir \"\")\n" + " (string=? dir \"/\")\n" + " (file-exists? dir))\n" + " (mkdir-p* (dirname dir))\n" + " (mkdir dir)))\n\n" + "(define (ensure-parent-directory file)\n" + " (mkdir-p* (dirname file)))\n\n" + pid1-helpers + "(register-services\n" + " (list\n" + " (service '(fruix-logger)\n" + " #:documentation \"Append a boot trace line for Fruix.\"\n" + " #:start (lambda _\n" + " (ensure-parent-directory \"/var/log/fruix-shepherd.log\")\n" + " (let ((port (open-file \"/var/log/fruix-shepherd.log\" \"a\")))\n" + " (display \"fruix-shepherd-started\\n\" port)\n" + " (close-port port))\n" + " #t)\n" + " #:stop (lambda _ #f)\n" + " #:respawn? #f)\n" + pid1-services + " (service '(fruix-ready)\n" + " #:documentation \"Write the Fruix ready marker.\"\n" + " #:requirement " ready-requirements "\n" + " #:start (lambda _\n" + " (ensure-parent-directory ready-marker)\n" + " (call-with-output-file ready-marker\n" + " (lambda (port) (display \"ready\" port)))\n" + " #t)\n" + " #:stop (lambda _ #f)\n" + " #:respawn? #f)))\n\n" + "(start-service (lookup-service 'fruix-ready))\n"))) + +(define (render-activation-rc-script) + (string-append + "#!/bin/sh\n" + "# PROVIDE: fruix_activate\n" + "# REQUIRE: FILESYSTEMS\n" + "# BEFORE: LOGIN sshd fruix_shepherd\n" + "# KEYWORD: shutdown\n\n" + ". /etc/rc.subr\n\n" + "name=fruix_activate\n" + "rcvar=fruix_activate_enable\n" + ": ${fruix_activate_enable:=YES}\n" + "start_cmd=fruix_activate_start\n" + "stop_cmd=:\n\n" + "fruix_activate_start()\n" + "{\n" + " /run/current-system/activate\n" + "}\n\n" + "load_rc_config $name\n" + "run_rc_command \"$1\"\n")) + +(define (render-rc-script shepherd-store guile-store guile-extra-store) + (let ((ld-library-path (string-append guile-extra-store "/lib:" + guile-store "/lib:/usr/local/lib")) + (guile-system-path + (string-append guile-store "/share/guile/3.0:" + guile-store "/share/guile/site/3.0:" + guile-store "/share/guile/site:" + guile-store "/share/guile")) + (guile-load-path (string-append shepherd-store "/share/guile/site/3.0:" + guile-extra-store "/share/guile/site/3.0")) + (guile-system-compiled-path + (string-append guile-store "/lib/guile/3.0/ccache:" + guile-store "/lib/guile/3.0/site-ccache")) + (guile-load-compiled-path + (string-append shepherd-store "/lib/guile/3.0/site-ccache:" + guile-extra-store "/lib/guile/3.0/site-ccache")) + (guile-system-extensions-path (string-append guile-store "/lib/guile/3.0/extensions")) + (guile-extensions-path (string-append guile-extra-store "/lib/guile/3.0/extensions"))) + (string-append + "#!/bin/sh\n" + "# PROVIDE: fruix_shepherd\n" + "# REQUIRE: FILESYSTEMS fruix_activate\n" + "# BEFORE: LOGIN\n" + "# KEYWORD: shutdown\n\n" + ". /etc/rc.subr\n\n" + "name=fruix_shepherd\n" + "rcvar=fruix_shepherd_enable\n" + ": ${fruix_shepherd_enable:=YES}\n" + "pidfile=/var/run/shepherd.pid\n" + "socket=/var/run/shepherd.sock\n" + "config=/run/current-system/shepherd/init.scm\n" + "logfile=/var/log/shepherd.log\n" + "command=" shepherd-store "/bin/shepherd\n" + "start_cmd=fruix_shepherd_start\n" + "stop_cmd=fruix_shepherd_stop\n" + "status_cmd=fruix_shepherd_status\n\n" + "fruix_shepherd_start()\n" + "{\n" + " /usr/sbin/daemon -c -f -p \"$pidfile\" -o /var/log/shepherd-bootstrap.out /usr/bin/env \\\n" + " LANG='C.UTF-8' LC_ALL='C.UTF-8' \\\n" + " LD_LIBRARY_PATH='" ld-library-path "' \\\n" + " GUILE_SYSTEM_PATH='" guile-system-path "' \\\n" + " GUILE_LOAD_PATH='" guile-load-path "' \\\n" + " GUILE_SYSTEM_COMPILED_PATH='" guile-system-compiled-path "' \\\n" + " GUILE_LOAD_COMPILED_PATH='" guile-load-compiled-path "' \\\n" + " GUILE_SYSTEM_EXTENSIONS_PATH='" guile-system-extensions-path "' \\\n" + " GUILE_EXTENSIONS_PATH='" guile-extensions-path "' \\\n" + " " guile-store "/bin/guile --no-auto-compile " shepherd-store "/bin/shepherd -I -s \"$socket\" -c \"$config\" -l \"$logfile\"\n" + " for _try in 1 2 3 4 5 6 7 8 9 10; do\n" + " [ -f \"$pidfile\" ] && [ -S \"$socket\" ] && return 0\n" + " sleep 1\n" + " done\n" + " return 1\n" + "}\n\n" + "fruix_shepherd_stop()\n" + "{\n" + " env LANG='C.UTF-8' LC_ALL='C.UTF-8' \\\n" + " LD_LIBRARY_PATH='" ld-library-path "' \\\n" + " GUILE_SYSTEM_PATH='" guile-system-path "' \\\n" + " GUILE_LOAD_PATH='" guile-load-path "' \\\n" + " GUILE_SYSTEM_COMPILED_PATH='" guile-system-compiled-path "' \\\n" + " GUILE_LOAD_COMPILED_PATH='" guile-load-compiled-path "' \\\n" + " GUILE_SYSTEM_EXTENSIONS_PATH='" guile-system-extensions-path "' \\\n" + " GUILE_EXTENSIONS_PATH='" guile-extensions-path "' \\\n" + " " guile-store "/bin/guile --no-auto-compile " shepherd-store "/bin/herd -s \"$socket\" stop root >/dev/null 2>&1 || true\n" + " for _try in 1 2 3 4 5 6 7 8 9 10; do\n" + " [ ! -f \"$pidfile\" ] && return 0\n" + " sleep 1\n" + " done\n" + " kill \"$(cat \"$pidfile\")\" >/dev/null 2>&1 || true\n" + " rm -f \"$pidfile\"\n" + " return 0\n" + "}\n\n" + "fruix_shepherd_status()\n" + "{\n" + " [ -f \"$pidfile\" ] && kill -0 \"$(cat \"$pidfile\")\" >/dev/null 2>&1\n" + "}\n\n" + "load_rc_config $name\n" + "run_rc_command \"$1\"\n"))) + + +(define* (operating-system-generated-files os #:key guile-store guile-extra-store shepherd-store) + (append + `(("boot/loader.conf" . ,(render-loader-conf os)) + ("etc/rc.conf" . ,(render-rc.conf os)) + ("etc/fstab" . ,(render-fstab os)) + ("etc/hosts" . ,(render-hosts os)) + ("etc/passwd" . ,(render-passwd os)) + ("etc/master.passwd" . ,(render-master-passwd os)) + ("etc/group" . ,(render-group os)) + ("etc/login.conf" . ,(render-login-conf)) + ("etc/shells" . ,(render-shells os)) + ("etc/motd" . ,(render-motd os)) + ("etc/ttys" . ,(render-ttys)) + ("activate" . ,(render-activation-script os + #:guile-store guile-store + #:guile-extra-store guile-extra-store + #:shepherd-store shepherd-store)) + ("shepherd/init.scm" . ,(render-shepherd-config os))) + (if (pid1-init-mode? os) + `(("boot/fruix-pid1" . ,(render-pid1-script os shepherd-store guile-store guile-extra-store))) + '()) + (if (sshd-enabled? os) + `(("etc/ssh/sshd_config" . ,(render-sshd-config os))) + '()) + (if (null? (operating-system-root-authorized-keys os)) + '() + `(("root/.ssh/authorized_keys" . ,(render-root-authorized-keys os)))))) + diff --git a/modules/fruix/system/freebsd/source.scm b/modules/fruix/system/freebsd/source.scm new file mode 100644 index 0000000..b4be051 --- /dev/null +++ b/modules/fruix/system/freebsd/source.scm @@ -0,0 +1,203 @@ +(define-module (fruix system freebsd source) + #:use-module (fruix packages freebsd) + #:use-module (fruix system freebsd model) + #:use-module (fruix system freebsd utils) + #:use-module (guix build utils) + #:use-module (srfi srfi-13) + #:export (materialize-freebsd-source + freebsd-source-materialization-spec)) + +(define freebsd-source-materializer-version "2") + +(define (string-downcase* value) + (list->string (map char-downcase (string->list value)))) + +(define (safe-name-fragment value) + (let* ((text (if (and (string? value) (not (string-null? value))) value "source")) + (chars (map (lambda (ch) + (if (or (char-alphabetic? ch) + (char-numeric? ch) + (memv ch '(#\- #\_ #\.))) + ch + #\-)) + (string->list text)))) + (list->string chars))) + +(define (freebsd-source-manifest source effective-source identity) + (string-append + "materializer-version=" freebsd-source-materializer-version "\n" + "declared-source=\n" + (object->string (freebsd-source-spec source)) + "\neffective-source=\n" + (object->string (freebsd-source-spec effective-source)) + "\nidentity=\n" + (object->string identity))) + +(define (ensure-git-source-cache source cache-dir) + (let* ((url (freebsd-source-url source)) + (repo-dir (string-append cache-dir "/git/" + (string-hash (string-append "git:" url)) + ".git"))) + (mkdir-p (dirname repo-dir)) + (unless (file-exists? repo-dir) + (unless (zero? (system* "git" "init" "--quiet" "--bare" repo-dir)) + (error "failed to initialize git source cache" repo-dir)) + (unless (zero? (system* "git" "-C" repo-dir "remote" "add" "origin" url)) + (error "failed to add git source remote" url))) + (let ((current-url (safe-command-output "git" "-C" repo-dir "remote" "get-url" "origin"))) + (unless (and current-url (string=? current-url url)) + (unless (zero? (system* "git" "-C" repo-dir "remote" "set-url" "origin" url)) + (error "failed to update git source remote" url)))) + repo-dir)) + +(define (resolve-git-freebsd-source source cache-dir) + (let* ((selector (or (freebsd-source-commit source) + (freebsd-source-ref source) + (error "git freebsd source requires a ref or commit" source))) + (repo-dir (ensure-git-source-cache source cache-dir))) + (unless (zero? (system* "git" "-C" repo-dir "fetch" "--quiet" "--depth" "1" "origin" selector)) + (error "failed to fetch git freebsd source" selector)) + (let ((resolved-commit (command-output "git" "-C" repo-dir "rev-parse" "FETCH_HEAD"))) + `((cache-path . ,repo-dir) + (effective-source . ,(freebsd-source #:name (freebsd-source-name source) + #:kind 'git + #:url (freebsd-source-url source) + #:ref (freebsd-source-ref source) + #:commit resolved-commit + #:sha256 #f)) + (identity . ((resolved-commit . ,resolved-commit))) + (populate-tree . ,(lambda (tree-root) + (let ((archive-path (string-append (dirname tree-root) "/git-export.tar"))) + (unless (zero? (system* "git" "-C" repo-dir "archive" + "--format=tar" "-o" archive-path resolved-commit)) + (error "failed to archive git freebsd source" resolved-commit)) + (unless (zero? (system* "tar" "-xpf" archive-path "-C" tree-root)) + (error "failed to extract archived git freebsd source" archive-path)) + (delete-path-if-exists archive-path)))))))) + +(define (normalize-expected-sha256 source) + (let ((sha256 (freebsd-source-sha256 source))) + (and sha256 (string-downcase* sha256)))) + +(define (resolve-txz-freebsd-source source cache-dir) + (let* ((url (freebsd-source-url source)) + (expected-sha256 (or (normalize-expected-sha256 source) + (error "src-txz freebsd source requires sha256 for materialization" source))) + (archive-path (string-append cache-dir "/archives/" + (string-hash (string-append "txz:" url)) + "-src.txz"))) + (mkdir-p (dirname archive-path)) + (when (file-exists? archive-path) + (let ((actual (string-downcase* (file-hash archive-path)))) + (unless (string=? actual expected-sha256) + (delete-file archive-path)))) + (unless (file-exists? archive-path) + (unless (zero? (system* "fetch" "-q" "-o" archive-path url)) + (error "failed to download FreeBSD src.txz source" url))) + (let ((actual-sha256 (string-downcase* (file-hash archive-path)))) + (unless (string=? actual-sha256 expected-sha256) + (error "downloaded src.txz hash mismatch" url expected-sha256 actual-sha256)) + `((cache-path . ,archive-path) + (effective-source . ,(freebsd-source #:name (freebsd-source-name source) + #:kind 'src-txz + #:url url + #:path #f + #:ref #f + #:commit #f + #:sha256 actual-sha256)) + (identity . ((archive-sha256 . ,actual-sha256))) + (populate-tree . ,(lambda (tree-root) + (unless (zero? (system* "tar" "-xpf" archive-path "-C" tree-root)) + (error "failed to extract FreeBSD src.txz source" archive-path)))))))) + +(define (resolve-local-freebsd-source source) + (let* ((path (freebsd-source-path source)) + (tree-sha256 (native-build-source-tree-sha256 path))) + `((cache-path . #f) + (effective-source . ,(freebsd-source #:name (freebsd-source-name source) + #:kind 'local-tree + #:url #f + #:path path + #:ref #f + #:commit #f + #:sha256 tree-sha256)) + (identity . ((tree-sha256 . ,tree-sha256))) + (populate-tree . ,(lambda (tree-root) + (copy-tree-contents path tree-root)))))) + +(define (detect-materialized-source-relative-root tree-root) + (cond + ((file-exists? (string-append tree-root "/Makefile")) + "tree") + ((file-exists? (string-append tree-root "/usr/src/Makefile")) + "tree/usr/src") + (else + "tree"))) + +(define* (materialize-freebsd-source source #:key + (store-dir "/frx/store") + (cache-dir "/frx/var/cache/fruix/freebsd-source")) + (validate-freebsd-source source) + (let* ((resolution (case (freebsd-source-kind source) + ((local-tree) + (resolve-local-freebsd-source source)) + ((git) + (resolve-git-freebsd-source source cache-dir)) + ((src-txz) + (resolve-txz-freebsd-source source cache-dir)) + (else + (error "unsupported freebsd source kind" (freebsd-source-kind source))))) + (effective-source (assoc-ref resolution 'effective-source)) + (identity (assoc-ref resolution 'identity)) + (manifest (freebsd-source-manifest source effective-source identity)) + (hash (string-hash manifest)) + (output-path (string-append store-dir "/" hash "-freebsd-source-" + (safe-name-fragment (freebsd-source-name source)))) + (info-file (string-append output-path "/.freebsd-source-info.scm")) + (cache-path (assoc-ref resolution 'cache-path)) + (populate-tree (assoc-ref resolution 'populate-tree))) + (unless (file-exists? output-path) + (let* ((temp-output (string-append output-path ".tmp")) + (temp-tree-root (string-append temp-output "/tree"))) + (delete-path-if-exists temp-output) + (mkdir-p temp-tree-root) + (populate-tree temp-tree-root) + (let* ((relative-root (detect-materialized-source-relative-root temp-tree-root)) + (source-root (string-append output-path "/" relative-root)) + (temp-source-root (string-append temp-output "/" relative-root)) + (tree-sha256 (native-build-source-tree-sha256 temp-source-root))) + (write-file (string-append temp-output "/.references") "") + (write-file (string-append temp-output "/.fruix-source") manifest) + (write-file (string-append temp-output "/.freebsd-source-info.scm") + (object->string + `((materializer-version . ,freebsd-source-materializer-version) + (declared-source . ,(freebsd-source-spec source)) + (effective-source . ,(freebsd-source-spec effective-source)) + (identity . ,identity) + (source-store . ,output-path) + (source-root . ,source-root) + (source-tree-sha256 . ,tree-sha256) + (cache-path . ,cache-path))))) + (rename-file temp-output output-path))) + (call-with-input-file info-file + (lambda (port) + (let* ((info (read port)) + (effective (assoc-ref info 'effective-source))) + `((source-store-path . ,output-path) + (source-root . ,(assoc-ref info 'source-root)) + (source-info-file . ,info-file) + (source-tree-sha256 . ,(assoc-ref info 'source-tree-sha256)) + (cache-path . ,(assoc-ref info 'cache-path)) + (effective-source . ,effective) + (effective-commit . ,(assoc-ref effective 'commit)) + (effective-sha256 . ,(assoc-ref effective 'sha256)))))))) + + +(define (freebsd-source-materialization-spec result) + `((source-store-path . ,(assoc-ref result 'source-store-path)) + (source-root . ,(assoc-ref result 'source-root)) + (source-info-file . ,(assoc-ref result 'source-info-file)) + (source-tree-sha256 . ,(assoc-ref result 'source-tree-sha256)) + (cache-path . ,(assoc-ref result 'cache-path)) + (effective-source . ,(assoc-ref result 'effective-source)))) + diff --git a/modules/fruix/system/freebsd/utils.scm b/modules/fruix/system/freebsd/utils.scm new file mode 100644 index 0000000..219198c --- /dev/null +++ b/modules/fruix/system/freebsd/utils.scm @@ -0,0 +1,243 @@ +(define-module (fruix system freebsd utils) + #:use-module (guix build utils) + #:use-module (ice-9 ftw) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 popen) + #:use-module (ice-9 hash-table) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-13) + #:use-module (rnrs io ports) + #:export (getenv* + trim-trailing-newlines + command-output + safe-command-output + write-file + string-hash + file-hash + directory-entries + path-signature + install-plan-signature + native-build-source-tree-sha256 + copy-regular-file + copy-node + materialize-plan-entry + delete-path-if-exists + stage-tree-into-output + string-replace-all + rewrite-text-file + delete-file-if-exists + copy-tree-contents + path-basename + read-lines + run-command + store-reference-closure + copy-store-items-into-rootfs + copy-rootfs-for-image + mktemp-directory)) + +(define (getenv* name default) + (or (getenv name) default)) + +(define (trim-trailing-newlines str) + (let loop ((len (string-length str))) + (if (and (> len 0) + (char=? (string-ref str (- len 1)) #\newline)) + (loop (- len 1)) + (substring str 0 len)))) + +(define (command-output program . args) + (let* ((port (apply open-pipe* OPEN_READ program args)) + (output (get-string-all port)) + (status (close-pipe port))) + (unless (zero? status) + (error (format #f "command failed: ~a ~s => ~a" program args status))) + (trim-trailing-newlines output))) + +(define (safe-command-output program . args) + (false-if-exception (apply command-output program args))) + +(define (write-file path content) + (mkdir-p (dirname path)) + (call-with-output-file path + (lambda (port) + (display content port)))) + +(define (string-hash text) + (let* ((tmp (string-append (getenv* "TMPDIR" "/tmp") "/fruix-system-hash.txt"))) + (write-file tmp text) + (command-output "sha256" "-q" tmp))) + +(define (file-hash path) + (command-output "sha256" "-q" path)) + + +(define (directory-entries path) + (sort (filter (lambda (entry) + (not (member entry '("." "..")))) + (scandir path)) + stringstring (stat:type st))))))) + +(define (install-plan-signature entry) + (match entry + (('file source target) + (string-append "file-target:" target "\n" (path-signature source))) + (('directory source target) + (string-append "directory-target:" target "\n" (path-signature source))) + (_ + (error (format #f "unsupported install plan entry: ~s" entry))))) + +(define (native-build-source-tree-sha256 source-root) + (let* ((mtree-output (command-output "mtree" "-c" "-k" "type,link,size,mode,sha256digest" "-p" source-root)) + (stable-lines (filter (lambda (line) + (not (string-prefix? "#" line))) + (string-split mtree-output #\newline)))) + (string-hash (string-join stable-lines "\n")))) + +(define (copy-regular-file source destination) + (let ((mode (stat:perms (stat source)))) + (copy-file source destination) + (chmod destination mode))) + +(define (copy-node source destination) + (let ((kind (stat:type (lstat source)))) + (mkdir-p (dirname destination)) + (case kind + ((directory) + (mkdir-p destination) + (for-each (lambda (entry) + (copy-node (string-append source "/" entry) + (string-append destination "/" entry))) + (directory-entries source))) + ((symlink) + (symlink (readlink source) destination)) + (else + (copy-regular-file source destination))))) + +(define (materialize-plan-entry output-path entry) + (match entry + (('file source target) + (copy-node source (string-append output-path "/" target))) + (('directory source target) + (copy-node source (string-append output-path "/" target))) + (_ + (error (format #f "unsupported install plan entry: ~s" entry))))) + +(define (clear-file-flags path) + (false-if-exception (system* "chflags" "-R" "noschg,nouchg" path))) + +(define (delete-path-if-exists path) + (when (or (file-exists? path) (false-if-exception (readlink path))) + (clear-file-flags path) + (let ((kind (stat:type (lstat path)))) + (case kind + ((directory) (delete-file-recursively path)) + (else (delete-file path)))))) + +(define (stage-tree-into-output stage-root output-path) + (mkdir-p output-path) + (for-each (lambda (entry) + (copy-node (string-append stage-root "/" entry) + (string-append output-path "/" entry))) + (directory-entries stage-root))) + + +(define (string-replace-all str old new) + (let ((old-len (string-length old))) + (let loop ((start 0) (chunks '())) + (let ((index (string-contains str old start))) + (if index + (loop (+ index old-len) + (cons new + (cons (substring str start index) chunks))) + (apply string-append + (reverse (cons (substring str start) chunks)))))))) + +(define (rewrite-text-file path replacements) + (when (file-exists? path) + (let* ((mode (stat:perms (stat path))) + (original (call-with-input-file path get-string-all)) + (updated (fold (lambda (replacement text) + (string-replace-all text (car replacement) (cdr replacement))) + original + replacements))) + (unless (string=? original updated) + (write-file path updated) + (chmod path mode))))) + +(define (delete-file-if-exists path) + (when (file-exists? path) + (delete-file path))) + + +(define (copy-tree-contents source-root target-root) + (mkdir-p target-root) + (for-each (lambda (entry) + (copy-node (string-append source-root "/" entry) + (string-append target-root "/" entry))) + (directory-entries source-root))) + + +(define (path-basename path) + (let ((parts (filter (lambda (part) (not (string-null? part))) + (string-split path #\/)))) + (if (null? parts) + path + (last parts)))) + +(define (read-lines path) + (if (file-exists? path) + (filter (lambda (line) (not (string-null? line))) + (string-split (call-with-input-file path get-string-all) #\newline)) + '())) + +(define (run-command . args) + (let ((status (apply system* args))) + (unless (zero? status) + (error "command failed" args status)) + #t)) + +(define (store-reference-closure roots) + (let ((seen (make-hash-table)) + (result '())) + (define (visit item) + (unless (hash-ref seen item #f) + (hash-set! seen item #t) + (set! result (cons item result)) + (for-each visit (read-lines (string-append item "/.references"))))) + (for-each visit roots) + (reverse result))) + +(define (copy-store-items-into-rootfs rootfs store-dir items) + (let ((store-root (string-append rootfs store-dir))) + (mkdir-p store-root) + (for-each (lambda (item) + (copy-node item (string-append store-root "/" (path-basename item)))) + items))) + +(define (copy-rootfs-for-image source-rootfs image-rootfs) + (when (file-exists? image-rootfs) + (delete-file-recursively image-rootfs)) + (copy-node source-rootfs image-rootfs)) + +(define (mktemp-directory pattern) + (command-output "mktemp" "-d" pattern)) +