From e2600ff810067f6eef71c3535f0a3ed8a4f82ea0 Mon Sep 17 00:00:00 2001 From: Steffen Beyer Date: Tue, 7 Apr 2026 05:27:58 +0200 Subject: [PATCH] channel: import canonical fruix code --- README.md | 51 +- bin/fruix | 44 + modules/fruix/packages/freebsd.scm | 817 +++++++++++ modules/fruix/shepherd/freebsd.scm | 104 ++ modules/fruix/system/freebsd.scm | 87 ++ modules/fruix/system/freebsd/build.scm | 936 ++++++++++++ modules/fruix/system/freebsd/executor.scm | 121 ++ modules/fruix/system/freebsd/media.scm | 1627 +++++++++++++++++++++ modules/fruix/system/freebsd/model.scm | 446 ++++++ modules/fruix/system/freebsd/render.scm | 1328 +++++++++++++++++ modules/fruix/system/freebsd/source.scm | 204 +++ modules/fruix/system/freebsd/utils.scm | 311 ++++ scripts/fruix.scm | 1072 ++++++++++++++ 13 files changed, 7137 insertions(+), 11 deletions(-) create mode 100755 bin/fruix create mode 100644 modules/fruix/packages/freebsd.scm create mode 100644 modules/fruix/shepherd/freebsd.scm create mode 100644 modules/fruix/system/freebsd.scm create mode 100644 modules/fruix/system/freebsd/build.scm create mode 100644 modules/fruix/system/freebsd/executor.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 create mode 100644 scripts/fruix.scm diff --git a/README.md b/README.md index e8cfed4..c4cdde8 100644 --- a/README.md +++ b/README.md @@ -1,17 +1,46 @@ # Fruix -Fruix is a Guix-like system running on FreeBSD but not GNU, using Shepherd, building GNU packages, with a BSD userland, and a functional store similar to Nix but not Nix. +`fruix` is the canonical Fruix repo/channel. -In Fruix, the FreeBSD platform is represented as foundational store artifacts and updated through the same generation mechanism as the rest of the system. +This repo is the long-lived source of truth for Fruix package, system, installer, deployment, and node-management logic. -Fruix is a system where everything that exists on the machine exists for a reason that can be explained. +## Scope -Every Fruix system must remain fully understandable and recoverable using only text files, a shell, and standard system tools. +Canonical Fruix content belongs here: -- Every host has a local config repository. -- Every host has a persistent system identity key. -- Every applied change corresponds to a commit and a generation. -- Secrets are declared in config but realized only at runtime. -- Secrets are encrypted to explicit recipients derived from host/user identity. -- Services explicitly declare their secret dependencies. -- The orchestration layer operates only through these primitives. +- package definitions +- system definitions +- source and promotion logic +- installer artifacts and future TUI installer +- deployment and installed-node lifecycle logic +- long-lived metadata formats + +`fruix-bootstrap` is separate and only exists to turn a plain FreeBSD host into a **Fruix builder** that can evaluate and materialize this repo. + +## Original channel URL + +The baked-in original channel URL is: + +- `https://git.teralink.net/self/fruix.git` + +Bootstrap wrappers may default to that origin while local development uses a sibling checkout such as: + +- `../fruix` + +## Current layout + +- `bin/fruix` — direct checkout entrypoint when dependencies are already available +- `scripts/fruix.scm` — canonical CLI implementation +- `modules/fruix/...` — canonical Fruix modules + +## Intended lifecycle + +```text +plain FreeBSD + -> fruix-bootstrap + -> Fruix builder + -> pinned fruix checkout + -> build Fruix artifacts + -> booted Fruix node + -> future lifecycle managed by fruix +``` diff --git a/bin/fruix b/bin/fruix new file mode 100755 index 0000000..664ddc0 --- /dev/null +++ b/bin/fruix @@ -0,0 +1,44 @@ +#!/bin/sh +set -eu + +project_root=$(CDPATH= cd -- "$(dirname "$0")/.." && pwd) +guix_source_dir=${GUIX_SOURCE_DIR:-"$HOME/repos/guix"} +guile_bin=${GUILE_BIN:-/tmp/guile-freebsd-validate-install/bin/guile} +guile_extra_prefix=${GUILE_EXTRA_PREFIX:-/tmp/guile-gnutls-freebsd-validate-install} +shepherd_prefix=${SHEPHERD_PREFIX:-/tmp/shepherd-freebsd-validate-install} +fruix_channel_url=${FRUIX_CHANNEL_URL:-https://git.teralink.net/self/fruix.git} +script=$project_root/scripts/fruix.scm +modules_dir=$project_root/modules + +if [ ! -x "$guile_bin" ]; then + echo "Guile binary is not executable: $guile_bin" >&2 + exit 1 +fi + +if [ ! -f "$script" ] || [ ! -d "$modules_dir" ]; then + echo "Canonical Fruix checkout is missing scripts/ or modules/: $project_root" >&2 + echo "Expected canonical Fruix content from $fruix_channel_url" >&2 + exit 1 +fi + +guile_prefix=$(CDPATH= cd -- "$(dirname "$guile_bin")/.." && pwd) +guile_lib_dir=$guile_prefix/lib + +if [ -n "${GUILE_LOAD_PATH:-}" ]; then + guile_load_path="$modules_dir:$guix_source_dir:$GUILE_LOAD_PATH" +else + guile_load_path="$modules_dir:$guix_source_dir" +fi + +exec env \ + GUILE_AUTO_COMPILE=0 \ + GUILE_LOAD_PATH="$guile_load_path" \ + LD_LIBRARY_PATH="$guile_lib_dir${LD_LIBRARY_PATH:+:$LD_LIBRARY_PATH}" \ + GUILE_PREFIX="$guile_prefix" \ + GUILE_EXTRA_PREFIX="$guile_extra_prefix" \ + SHEPHERD_PREFIX="$shepherd_prefix" \ + GUIX_SOURCE_DIR="$guix_source_dir" \ + FRUIX_PROJECT_ROOT="$project_root" \ + FRUIX_CHANNEL_DIR="$project_root" \ + FRUIX_CHANNEL_URL="$fruix_channel_url" \ + "$guile_bin" --no-auto-compile -s "$script" "$@" diff --git a/modules/fruix/packages/freebsd.scm b/modules/fruix/packages/freebsd.scm new file mode 100644 index 0000000..fafcd0a --- /dev/null +++ b/modules/fruix/packages/freebsd.scm @@ -0,0 +1,817 @@ +(define-module (fruix packages freebsd) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-13) + #:export (freebsd-release + freebsd-source + freebsd-source? + freebsd-source-name + freebsd-source-kind + freebsd-source-url + freebsd-source-path + freebsd-source-ref + freebsd-source-commit + freebsd-source-sha256 + %default-freebsd-source + freebsd-base + freebsd-base? + freebsd-base-name + freebsd-base-version-label + freebsd-base-release + freebsd-base-branch + freebsd-base-source-root + freebsd-base-source + freebsd-base-target + freebsd-base-target-arch + freebsd-base-kernconf + freebsd-base-make-flags + %default-freebsd-base + freebsd-package + freebsd-package? + freebsd-package-name + freebsd-package-version + freebsd-package-build-system + freebsd-package-inputs + freebsd-package-home-page + freebsd-package-synopsis + freebsd-package-description + freebsd-package-license + freebsd-package-install-plan + freebsd-kernel + freebsd-kernel-headers + freebsd-libc + freebsd-bootloader + freebsd-rc-scripts + freebsd-runtime + freebsd-networking + freebsd-openssh + freebsd-userland + freebsd-clang-toolchain + freebsd-gmake + freebsd-autotools + freebsd-openssl + freebsd-zlib + freebsd-sh + freebsd-bash + freebsd-native-kernel + freebsd-native-world + freebsd-native-runtime + freebsd-native-bootloader + freebsd-native-headers + freebsd-native-kernel-for + freebsd-native-world-for + freebsd-native-runtime-for + freebsd-native-bootloader-for + freebsd-native-headers-for + freebsd-native-system-packages-for + freebsd-native-development-profile-packages-for + freebsd-native-build-package? + freebsd-host-staged-package? + %freebsd-native-system-packages + %freebsd-native-development-profile-packages + %freebsd-host-staged-all-packages + %freebsd-host-staged-core-packages + %freebsd-host-staged-development-profile-packages + %freebsd-host-staged-system-packages + %freebsd-host-staged-replacement-order + %freebsd-core-packages + %freebsd-development-profile-packages + %freebsd-system-packages)) + +(define-record-type + (make-freebsd-package name version build-system inputs home-page synopsis + description license install-plan) + freebsd-package? + (name freebsd-package-name) + (version freebsd-package-version) + (build-system freebsd-package-build-system) + (inputs freebsd-package-inputs) + (home-page freebsd-package-home-page) + (synopsis freebsd-package-synopsis) + (description freebsd-package-description) + (license freebsd-package-license) + (install-plan freebsd-package-install-plan)) + +(define* (freebsd-package #:key name version build-system (inputs '()) home-page + synopsis description license install-plan) + (make-freebsd-package name version build-system inputs home-page synopsis + description license install-plan)) + +(define freebsd-release "15.0-STABLE") + +(define-record-type + (make-freebsd-source name kind url path ref commit sha256) + freebsd-source? + (name freebsd-source-name) + (kind freebsd-source-kind) + (url freebsd-source-url) + (path freebsd-source-path) + (ref freebsd-source-ref) + (commit freebsd-source-commit) + (sha256 freebsd-source-sha256)) + +(define* (freebsd-source #:key + (name "default") + (kind 'local-tree) + (url (and (eq? kind 'git) "https://git.FreeBSD.org/src.git")) + (path (and (eq? kind 'local-tree) "/usr/src")) + (ref #f) + (commit #f) + (sha256 #f)) + (make-freebsd-source name kind url path ref commit sha256)) + +(define %default-freebsd-source + (freebsd-source)) + +(define-record-type + (make-freebsd-base name version-label release branch source-root source target + target-arch kernconf make-flags) + freebsd-base? + (name freebsd-base-name) + (version-label freebsd-base-version-label) + (release freebsd-base-release) + (branch freebsd-base-branch) + (source-root freebsd-base-source-root) + (source freebsd-base-source) + (target freebsd-base-target) + (target-arch freebsd-base-target-arch) + (kernconf freebsd-base-kernconf) + (make-flags freebsd-base-make-flags)) + +(define default-native-make-flags + '("__MAKE_CONF=/dev/null" + "SRCCONF=/dev/null" + "SRC_ENV_CONF=/dev/null" + "MK_DEBUG_FILES=no" + "MK_TESTS=no")) + +(define (default-freebsd-branch release) + (let ((major (car (string-split release #\.)))) + (cond + ((string-contains release "STABLE") + (string-append "stable/" major)) + ((string-contains release "RELEASE") + (string-append "releng/" major)) + (else + "unknown")))) + +(define* (freebsd-base #:key + (name "default") + (version-label freebsd-release) + (release freebsd-release) + (branch (default-freebsd-branch release)) + (source #f) + (source-root #f) + (target "amd64") + (target-arch "amd64") + (kernconf "GENERIC") + (make-flags default-native-make-flags)) + (let* ((source (or source %default-freebsd-source)) + (source-root (or source-root + (freebsd-source-path source) + "/usr/src"))) + (make-freebsd-base name version-label release branch source-root source target + target-arch kernconf make-flags))) + +(define %default-freebsd-base + (freebsd-base)) + +(define freebsd-kernel + (freebsd-package + #:name "freebsd-kernel" + #:version freebsd-release + #:build-system 'copy-build-system + #:home-page "https://www.freebsd.org/" + #:synopsis "Prototype package for the running FreeBSD kernel" + #:description + "Prototype package definition that stages the currently installed FreeBSD +kernel image into a store-like output for FreeBSD porting experiments." + #:license 'bsd-2 + #:install-plan + '((file "/boot/kernel/kernel" "boot/kernel/kernel") + (file "/boot/kernel/linker.hints" "boot/kernel/linker.hints")))) + +(define freebsd-kernel-headers + (freebsd-package + #:name "freebsd-kernel-headers" + #:version freebsd-release + #:build-system 'copy-build-system + #:home-page "https://www.freebsd.org/" + #:synopsis "Prototype package for FreeBSD kernel headers" + #:description + "Prototype package definition that stages a minimal set of FreeBSD kernel +header directories from /usr/src for Guix porting experiments." + #:license 'bsd-2 + #:install-plan + '((directory "/usr/src/sys/sys" "include/sys")))) + +(define freebsd-libc + (freebsd-package + #:name "freebsd-libc" + #:version freebsd-release + #:build-system 'copy-build-system + #:inputs (list freebsd-kernel-headers) + #:home-page "https://www.freebsd.org/" + #:synopsis "Prototype package for FreeBSD libc and userland headers" + #:description + "Prototype package definition that stages FreeBSD libc, the dynamic loader, +and the userland C headers needed for development profiles." + #:license 'bsd-2 + #:install-plan + '((file "/lib/libc.so.7" "lib/libc.so.7") + (file "/lib/libsys.so.7" "lib/libsys.so.7") + (file "/lib/libthr.so.3" "lib/libthr.so.3") + (file "/lib/libutil.so.10" "lib/libutil.so.10") + (file "/lib/libxo.so.0" "lib/libxo.so.0") + (file "/lib/libgeom.so.5" "lib/libgeom.so.5") + (file "/lib/libc++.so.1" "lib/libc++.so.1") + (file "/lib/libcxxrt.so.1" "lib/libcxxrt.so.1") + (file "/lib/libgcc_s.so.1" "lib/libgcc_s.so.1") + (file "/lib/libm.so.5" "lib/libm.so.5") + (file "/lib/libelf.so.2" "lib/libelf.so.2") + (file "/lib/libkvm.so.7" "lib/libkvm.so.7") + (file "/lib/lib80211.so.1" "lib/lib80211.so.1") + (file "/lib/libjail.so.1" "lib/libjail.so.1") + (file "/lib/libnv.so.1" "lib/libnv.so.1") + (file "/lib/libsbuf.so.6" "lib/libsbuf.so.6") + (file "/lib/libbsdxml.so.4" "lib/libbsdxml.so.4") + (file "/lib/libcrypt.so.5" "lib/libcrypt.so.5") + (file "/lib/libmd.so.7" "lib/libmd.so.7") + (file "/lib/libedit.so.8" "lib/libedit.so.8") + (file "/lib/libtinfow.so.9" "lib/libtinfow.so.9") + (file "/lib/libcasper.so.1" "lib/libcasper.so.1") + (file "/lib/libcap_syslog.so.1" "lib/libcap_syslog.so.1") + (file "/lib/libcap_fileargs.so.1" "lib/libcap_fileargs.so.1") + (file "/lib/libcap_net.so.1" "lib/libcap_net.so.1") + (file "/lib/libufs.so.8" "lib/libufs.so.8") + (file "/usr/lib/libdevinfo.so.7" "usr/lib/libdevinfo.so.7") + (file "/usr/lib/libdevctl.so.5" "usr/lib/libdevctl.so.5") + (file "/lib/libz.so.6" "lib/libz.so.6") + (file "/lib/libcrypto.so.35" "lib/libcrypto.so.35") + (file "/usr/lib/libssl.so.35" "usr/lib/libssl.so.35") + (file "/usr/lib/libdl.so.1" "usr/lib/libdl.so.1") + (file "/usr/lib/libpam.so.6" "usr/lib/libpam.so.6") + (file "/usr/lib/libbsm.so.3" "usr/lib/libbsm.so.3") + (file "/usr/lib/libblocklist.so.0" "usr/lib/libblocklist.so.0") + (file "/usr/lib/libregex.so.1" "usr/lib/libregex.so.1") + (file "/usr/lib/libprivatessh.so.5" "usr/lib/libprivatessh.so.5") + (file "/usr/lib/libprivateldns.so.5" "usr/lib/libprivateldns.so.5") + (file "/usr/lib/libwrap.so.6" "usr/lib/libwrap.so.6") + (file "/usr/lib/libgssapi_krb5.so.122" "usr/lib/libgssapi_krb5.so.122") + (file "/usr/lib/libkrb5.so.122" "usr/lib/libkrb5.so.122") + (file "/usr/lib/libk5crypto.so.122" "usr/lib/libk5crypto.so.122") + (file "/usr/lib/libcom_err.so.122" "usr/lib/libcom_err.so.122") + (file "/usr/lib/libkrb5support.so.122" "usr/lib/libkrb5support.so.122") + (file "/libexec/ld-elf.so.1" "libexec/ld-elf.so.1")))) + +(define freebsd-bootloader + (freebsd-package + #:name "freebsd-bootloader" + #:version freebsd-release + #:build-system 'copy-build-system + #:inputs (list freebsd-libc) + #:home-page "https://www.freebsd.org/" + #:synopsis "Prototype package for FreeBSD loader and boot assets" + #:description + "Prototype package definition that stages the FreeBSD boot loader and the +minimal loader support tree needed for declarative system-closure experiments." + #:license 'bsd-2 + #:install-plan + '((file "/boot/loader" "boot/loader") + (file "/boot/loader.efi" "boot/loader.efi") + (file "/boot/device.hints" "boot/device.hints") + (directory "/boot/defaults" "boot/defaults") + (directory "/boot/lua" "boot/lua")))) + +(define freebsd-sh + (freebsd-package + #:name "freebsd-sh" + #:version freebsd-release + #:build-system 'copy-build-system + #:inputs (list freebsd-libc) + #:home-page "https://www.freebsd.org/" + #:synopsis "Prototype package for the FreeBSD POSIX shell" + #:description + "Prototype package definition that stages the base system POSIX shell from +FreeBSD." + #:license 'bsd-2 + #:install-plan + '((file "/bin/sh" "bin/sh")))) + +(define freebsd-userland + (freebsd-package + #:name "freebsd-userland" + #:version freebsd-release + #:build-system 'copy-build-system + #:inputs (list freebsd-libc freebsd-sh) + #:home-page "https://www.freebsd.org/" + #:synopsis "Prototype package for selected FreeBSD userland utilities" + #:description + "Prototype package definition that stages a small set of base FreeBSD +userland commands needed for development and build experiments." + #:license 'bsd-2 + #:install-plan + '((file "/bin/cat" "bin/cat") + (file "/bin/chflags" "bin/chflags") + (file "/bin/chmod" "bin/chmod") + (file "/bin/cp" "bin/cp") + (file "/bin/date" "bin/date") + (file "/bin/dd" "bin/dd") + (file "/bin/echo" "bin/echo") + (file "/bin/expr" "bin/expr") + (file "/bin/ln" "bin/ln") + (file "/bin/ls" "bin/ls") + (file "/bin/mkdir" "bin/mkdir") + (file "/bin/mv" "bin/mv") + (file "/bin/ps" "bin/ps") + (file "/bin/pwd" "bin/pwd") + (file "/bin/rmdir" "bin/rmdir") + (file "/bin/rm" "bin/rm") + (file "/bin/sleep" "bin/sleep") + (file "/bin/stty" "bin/stty") + (file "/bin/sync" "bin/sync") + (file "/usr/bin/awk" "usr/bin/awk") + (file "/usr/bin/basename" "usr/bin/basename") + (file "/usr/bin/cap_mkdb" "usr/bin/cap_mkdb") + (file "/usr/bin/cut" "usr/bin/cut") + (file "/usr/bin/dirname" "usr/bin/dirname") + (file "/usr/bin/egrep" "usr/bin/egrep") + (file "/usr/bin/env" "usr/bin/env") + (file "/usr/bin/find" "bin/find") + (file "/usr/bin/fsync" "usr/bin/fsync") + (file "/usr/bin/grep" "usr/bin/grep") + (file "/usr/bin/mktemp" "usr/bin/mktemp") + (file "/usr/bin/head" "usr/bin/head") + (file "/usr/bin/install" "usr/bin/install") + (file "/usr/bin/limits" "usr/bin/limits") + (file "/usr/bin/logger" "usr/bin/logger") + (file "/usr/bin/readlink" "usr/bin/readlink") + (file "/usr/bin/sed" "usr/bin/sed") + (file "/usr/bin/sort" "usr/bin/sort") + (file "/usr/bin/tar" "bin/tar") + (file "/usr/bin/tr" "usr/bin/tr") + (file "/usr/bin/uname" "usr/bin/uname") + (file "/usr/bin/xargs" "bin/xargs")))) + +(define freebsd-rc-scripts + (freebsd-package + #:name "freebsd-rc-scripts" + #:version freebsd-release + #:build-system 'copy-build-system + #:inputs (list freebsd-sh) + #:home-page "https://www.freebsd.org/" + #:synopsis "Prototype package for FreeBSD init and rc script assets" + #:description + "Prototype package definition that stages the FreeBSD init and rc support +files needed by the first Fruix system-closure experiments." + #:license 'bsd-2 + #:install-plan + '((file "/etc/rc" "etc/rc") + (file "/etc/rc.subr" "etc/rc.subr") + (file "/etc/rc.shutdown" "etc/rc.shutdown") + (file "/etc/devd.conf" "etc/devd.conf") + (file "/etc/network.subr" "etc/network.subr") + (file "/etc/newsyslog.conf" "etc/newsyslog.conf") + (file "/etc/syslog.conf" "etc/syslog.conf") + (directory "/etc/rc.d" "etc/rc.d") + (directory "/etc/defaults" "etc/defaults")))) + +(define freebsd-runtime + (freebsd-package + #:name "freebsd-runtime" + #:version freebsd-release + #:build-system 'copy-build-system + #:inputs (list freebsd-libc freebsd-sh freebsd-userland freebsd-rc-scripts) + #:home-page "https://www.freebsd.org/" + #:synopsis "Prototype package for the minimal FreeBSD runtime" + #:description + "Prototype package definition that stages the minimal FreeBSD runtime +commands needed by the first declarative Fruix system and activation payload +experiments." + #:license 'bsd-2 + #:install-plan + '((file "/sbin/adjkerntz" "sbin/adjkerntz") + (file "/usr/sbin/daemon" "usr/sbin/daemon") + (file "/sbin/devd" "sbin/devd") + (file "/sbin/devmatch" "sbin/devmatch") + (file "/sbin/dmesg" "sbin/dmesg") + (file "/sbin/fsck" "sbin/fsck") + (file "/sbin/fsck_ufs" "sbin/fsck_ufs") + (file "/sbin/gpart" "sbin/gpart") + (file "/sbin/init" "sbin/init") + (file "/sbin/ifconfig" "sbin/ifconfig") + (file "/sbin/md5" "sbin/md5") + (file "/sbin/mount" "sbin/mount") + (file "/sbin/rcorder" "sbin/rcorder") + (file "/sbin/reboot" "sbin/reboot") + (file "/sbin/sha256" "sbin/sha256") + (file "/sbin/shutdown" "sbin/shutdown") + (file "/sbin/swapon" "sbin/swapon") + (file "/sbin/sysctl" "sbin/sysctl") + (file "/usr/sbin/chown" "usr/sbin/chown") + (file "/usr/sbin/cron" "usr/sbin/cron") + (file "/usr/sbin/devctl" "usr/sbin/devctl") + (file "/usr/sbin/nologin" "usr/sbin/nologin") + (file "/usr/sbin/pwd_mkdb" "usr/sbin/pwd_mkdb") + (file "/usr/sbin/service" "usr/sbin/service") + (file "/usr/sbin/ip6addrctl" "usr/sbin/ip6addrctl") + (file "/usr/sbin/newsyslog" "usr/sbin/newsyslog") + (file "/usr/sbin/syslogd" "usr/sbin/syslogd") + (file "/usr/sbin/utx" "usr/sbin/utx") + (file "/usr/bin/id" "usr/bin/id") + (file "/sbin/kldload" "sbin/kldload") + (file "/sbin/kldstat" "sbin/kldstat") + (file "/sbin/devfs" "sbin/devfs") + (file "/bin/freebsd-version" "bin/freebsd-version") + (file "/bin/hostname" "bin/hostname") + (file "/bin/kenv" "bin/kenv") + (file "/usr/share/locale/C.UTF-8/LC_CTYPE" "usr/share/locale/C.UTF-8/LC_CTYPE")))) + +(define freebsd-networking + (freebsd-package + #:name "freebsd-networking" + #:version freebsd-release + #:build-system 'copy-build-system + #:inputs (list freebsd-libc freebsd-runtime freebsd-sh) + #:home-page "https://www.freebsd.org/" + #:synopsis "Prototype package for FreeBSD network runtime tools" + #:description + "Prototype package definition that stages the minimal FreeBSD networking +runtime needed for DHCP-based boot validation in virtual machines." + #:license 'bsd-2 + #:install-plan + '((file "/sbin/dhclient" "sbin/dhclient") + (file "/sbin/dhclient-script" "sbin/dhclient-script") + (file "/sbin/route" "sbin/route") + (file "/usr/bin/netstat" "usr/bin/netstat") + (file "/usr/sbin/arp" "usr/sbin/arp")))) + +(define freebsd-openssh + (freebsd-package + #:name "freebsd-openssh" + #:version freebsd-release + #:build-system 'copy-build-system + #:inputs (list freebsd-libc freebsd-runtime freebsd-sh) + #:home-page "https://www.freebsd.org/" + #:synopsis "Prototype package for the FreeBSD OpenSSH runtime" + #:description + "Prototype package definition that stages the FreeBSD OpenSSH server and +client tools needed for first-boot operator access on the Fruix prototype +track." + #:license 'bsd-2 + #:install-plan + '((file "/usr/sbin/sshd" "usr/sbin/sshd") + (file "/usr/bin/ssh" "usr/bin/ssh") + (file "/usr/bin/ssh-keygen" "usr/bin/ssh-keygen") + (file "/usr/libexec/sshd-auth" "usr/libexec/sshd-auth") + (file "/usr/libexec/sshd-session" "usr/libexec/sshd-session") + (file "/etc/ssh/moduli" "etc/ssh/moduli")))) + +(define freebsd-clang-toolchain + (freebsd-package + #:name "freebsd-clang-toolchain" + #:version freebsd-release + #:build-system 'copy-build-system + #:inputs (list freebsd-libc freebsd-kernel-headers freebsd-sh) + #:home-page "https://www.freebsd.org/" + #:synopsis "Prototype package for the FreeBSD Clang toolchain" + #:description + "Prototype package definition that stages the base FreeBSD Clang-based C +and C++ toolchain into a profile-friendly output." + #:license 'bsd-2 + #:install-plan + '((file "/usr/bin/cc" "bin/cc") + (file "/usr/bin/c++" "bin/c++") + (file "/usr/bin/clang" "bin/clang") + (file "/usr/bin/clang++" "bin/clang++") + (file "/usr/bin/ar" "bin/ar") + (file "/usr/bin/ranlib" "bin/ranlib") + (file "/usr/bin/nm" "bin/nm") + (file "/usr/bin/ld" "bin/ld")))) + +(define freebsd-gmake + (freebsd-package + #:name "freebsd-gmake" + #:version "4.4.1" + #:build-system 'copy-build-system + #:inputs (list freebsd-sh freebsd-libc) + #:home-page "https://www.gnu.org/software/make/" + #:synopsis "Prototype package for GNU Make on FreeBSD" + #:description + "Prototype package definition that stages the GNU Make binary from the +FreeBSD ports collection for use in build profiles." + #:license 'gpl3+ + #:install-plan + '((file "/usr/local/bin/gmake" "bin/gmake") + (file "/usr/local/bin/gmake" "bin/make")))) + +(define freebsd-bash + (freebsd-package + #:name "freebsd-bash" + #:version "5.3.9" + #:build-system 'copy-build-system + #:inputs (list freebsd-libc) + #:home-page "https://www.gnu.org/software/bash/" + #:synopsis "Prototype package for GNU Bash on FreeBSD" + #:description + "Prototype package definition that stages the Bash binary from the +FreeBSD ports collection for development profiles." + #:license 'gpl3+ + #:install-plan + '((file "/usr/local/bin/bash" "bin/bash")))) + +(define freebsd-autotools + (freebsd-package + #:name "freebsd-autotools" + #:version "2026-04" + #:build-system 'copy-build-system + #:inputs (list freebsd-gmake freebsd-bash freebsd-libc) + #:home-page "https://www.gnu.org/software/autoconf/" + #:synopsis "Prototype package for Autotools on FreeBSD" + #:description + "Prototype package definition that stages the Autoconf, Automake, Libtool, +pkg-config, and GNU m4 tools needed by FreeBSD Guix build experiments." + #:license 'gpl3+ + #:install-plan + '((file "/usr/local/bin/autoconf" "bin/autoconf") + (file "/usr/local/bin/autoheader" "bin/autoheader") + (file "/usr/local/bin/autom4te" "bin/autom4te") + (file "/usr/local/bin/automake" "bin/automake") + (file "/usr/local/bin/aclocal" "bin/aclocal") + (file "/usr/local/bin/autoreconf" "bin/autoreconf") + (file "/usr/local/bin/libtoolize" "bin/libtoolize") + (file "/usr/local/bin/pkg-config" "bin/pkg-config") + (file "/usr/local/bin/gm4" "bin/m4") + (directory "/usr/local/share/autoconf2.72" "share/autoconf2.72") + (directory "/usr/local/share/automake-1.18" "share/automake-1.18") + (directory "/usr/local/share/aclocal" "share/aclocal") + (directory "/usr/local/share/libtool" "share/libtool")))) + +(define freebsd-openssl + (freebsd-package + #:name "freebsd-openssl" + #:version freebsd-release + #:build-system 'copy-build-system + #:inputs (list freebsd-libc) + #:home-page "https://www.openssl.org/" + #:synopsis "Prototype package for OpenSSL libraries from FreeBSD base" + #:description + "Prototype package definition that stages the OpenSSL shared libraries +shipped with FreeBSD base." + #:license 'openssl + #:install-plan + '((file "/usr/lib/libcrypto.so" "lib/libcrypto.so") + (file "/usr/lib/libssl.so" "lib/libssl.so")))) + +(define freebsd-zlib + (freebsd-package + #:name "freebsd-zlib" + #:version freebsd-release + #:build-system 'copy-build-system + #:inputs (list freebsd-libc) + #:home-page "https://zlib.net/" + #:synopsis "Prototype package for zlib from FreeBSD base" + #:description + "Prototype package definition that stages the base FreeBSD zlib shared +library for profile experiments." + #:license 'zlib + #:install-plan + '((file "/lib/libz.so.6" "lib/libz.so.6")))) + +(define default-native-world-prune-paths + '("usr/share/doc" + "usr/share/examples" + "usr/share/info" + "usr/share/man" + "usr/tests")) + +(define default-native-runtime-prune-paths + '("boot" + "rescue" + "usr/include" + "usr/lib/debug" + "usr/lib32" + "usr/obj" + "usr/src" + "usr/share/doc" + "usr/share/examples" + "usr/share/info" + "usr/share/man" + "usr/share/mk" + "usr/tests")) + +(define default-native-bootloader-keep-paths + '("boot/loader" + "boot/loader.efi" + "boot/device.hints" + "boot/defaults" + "boot/lua")) + +(define default-native-headers-keep-paths + '("usr/include" + "usr/share/mk")) + +(define (freebsd-base-native-plan base) + `((base-name . ,(freebsd-base-name base)) + (base-version-label . ,(freebsd-base-version-label base)) + (base-release . ,(freebsd-base-release base)) + (base-branch . ,(freebsd-base-branch base)) + (base-source-name . ,(freebsd-source-name (freebsd-base-source base))) + (base-source-kind . ,(freebsd-source-kind (freebsd-base-source base))) + (base-source-url . ,(freebsd-source-url (freebsd-base-source base))) + (base-source-path . ,(freebsd-source-path (freebsd-base-source base))) + (base-source-ref . ,(freebsd-source-ref (freebsd-base-source base))) + (base-source-commit . ,(freebsd-source-commit (freebsd-base-source base))) + (base-source-sha256 . ,(freebsd-source-sha256 (freebsd-base-source base))) + (source-root . ,(freebsd-base-source-root 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-native-plan base extra-fields) + (append (freebsd-base-native-plan base) extra-fields)) + +(define (freebsd-native-kernel-for base) + (freebsd-package + #:name "freebsd-native-kernel" + #:version (freebsd-base-version-label base) + #:build-system 'freebsd-kernel-build-system + #:home-page "https://www.freebsd.org/" + #:synopsis "Native Fruix-managed FreeBSD kernel artifact" + #:description + "FreeBSD-specific package definition that builds a kernel from a declared +FreeBSD base input and stages the resulting boot/kernel tree as a real Fruix +store artifact." + #:license 'bsd-2 + #:install-plan + (freebsd-native-plan base '()))) + +(define (freebsd-native-world-for base) + (freebsd-package + #:name "freebsd-native-world" + #:version (freebsd-base-version-label base) + #:build-system 'freebsd-world-build-system + #:home-page "https://www.freebsd.org/" + #:synopsis "Native Fruix-managed FreeBSD world artifact" + #:description + "FreeBSD-specific package definition that builds and installs a broad +native world from a declared FreeBSD base input into a real Fruix store +artifact." + #:license 'bsd-2 + #:install-plan + (freebsd-native-plan base + `((prune-paths . ,default-native-world-prune-paths))))) + +(define (freebsd-native-runtime-for base) + (freebsd-package + #:name "freebsd-native-runtime" + #:version (freebsd-base-version-label base) + #:build-system 'freebsd-world-build-system + #:home-page "https://www.freebsd.org/" + #:synopsis "Native Fruix-managed FreeBSD runtime slice" + #:description + "FreeBSD-specific package definition that stages a runtime-focused slice of +installworld/distribution from a declared FreeBSD base input." + #:license 'bsd-2 + #:install-plan + (freebsd-native-plan base + `((prune-paths . ,default-native-runtime-prune-paths))))) + +(define (freebsd-native-bootloader-for base) + (freebsd-package + #:name "freebsd-native-bootloader" + #:version (freebsd-base-version-label base) + #:build-system 'freebsd-world-build-system + #:home-page "https://www.freebsd.org/" + #:synopsis "Native Fruix-managed FreeBSD boot asset slice" + #:description + "FreeBSD-specific package definition that stages only the loader and boot +support assets needed by the validated Fruix image path from a declared +FreeBSD base input." + #:license 'bsd-2 + #:install-plan + (freebsd-native-plan base + `((keep-paths . ,default-native-bootloader-keep-paths))))) + +(define (freebsd-native-headers-for base) + (freebsd-package + #:name "freebsd-native-headers" + #:version (freebsd-base-version-label base) + #:build-system 'freebsd-world-build-system + #:home-page "https://www.freebsd.org/" + #:synopsis "Native Fruix-managed FreeBSD headers slice" + #:description + "FreeBSD-specific package definition that stages the userland header set and +build-system support files from installworld/distribution for a declared +FreeBSD base input." + #:license 'bsd-2 + #:install-plan + (freebsd-native-plan base + `((keep-paths . ,default-native-headers-keep-paths))))) + +(define freebsd-native-kernel + (freebsd-native-kernel-for %default-freebsd-base)) + +(define freebsd-native-world + (freebsd-native-world-for %default-freebsd-base)) + +(define freebsd-native-runtime + (freebsd-native-runtime-for %default-freebsd-base)) + +(define freebsd-native-bootloader + (freebsd-native-bootloader-for %default-freebsd-base)) + +(define freebsd-native-headers + (freebsd-native-headers-for %default-freebsd-base)) + +(define (freebsd-native-build-package? package) + (not (not (memq (freebsd-package-build-system package) + '(freebsd-kernel-build-system freebsd-world-build-system))))) + +;; Transitional boundary: the FreeBSD base layer below is still staged by +;; copying selected artifacts from the builder host. Plan 3 keeps these +;; package sets explicit so they can be replaced incrementally by native +;; FreeBSD world/kernel build outputs in /frx/store. + +(define %freebsd-host-staged-core-packages + (list freebsd-kernel + freebsd-kernel-headers + freebsd-libc + freebsd-userland + freebsd-clang-toolchain + freebsd-gmake + freebsd-autotools + freebsd-openssl + freebsd-zlib + freebsd-sh + freebsd-bash)) + +(define %freebsd-host-staged-development-profile-packages + (list freebsd-kernel + freebsd-kernel-headers + freebsd-libc + freebsd-userland + freebsd-clang-toolchain + freebsd-gmake + freebsd-autotools + freebsd-openssl + freebsd-zlib + freebsd-sh + freebsd-bash)) + +(define %freebsd-host-staged-system-packages + (list freebsd-kernel + freebsd-bootloader + freebsd-libc + freebsd-rc-scripts + freebsd-runtime + freebsd-networking + freebsd-openssh + freebsd-userland + freebsd-sh + freebsd-bash)) + +(define %freebsd-host-staged-all-packages + (delete-duplicates + (append %freebsd-host-staged-core-packages + %freebsd-host-staged-development-profile-packages + %freebsd-host-staged-system-packages))) + +(define (freebsd-host-staged-package? package) + (and (not (freebsd-native-build-package? package)) + (any (lambda (candidate) + (string=? (freebsd-package-name candidate) + (freebsd-package-name package))) + %freebsd-host-staged-all-packages))) + +(define %freebsd-host-staged-replacement-order + '((first-wave . (freebsd-kernel freebsd-bootloader)) + (second-wave . (freebsd-runtime freebsd-libc freebsd-userland freebsd-rc-scripts)) + (third-wave . (freebsd-networking freebsd-openssh)) + (fourth-wave . (freebsd-kernel-headers freebsd-clang-toolchain)) + (fifth-wave . (freebsd-gmake freebsd-autotools freebsd-openssl freebsd-zlib freebsd-sh freebsd-bash)))) + +(define (freebsd-native-system-packages-for base) + (list (freebsd-native-runtime-for base))) + +(define (freebsd-native-development-profile-packages-for base) + (list (freebsd-native-runtime-for base) + (freebsd-native-headers-for base) + freebsd-clang-toolchain + freebsd-gmake + freebsd-autotools + freebsd-openssl + freebsd-zlib + freebsd-sh + freebsd-bash)) + +(define %freebsd-native-system-packages + (freebsd-native-system-packages-for %default-freebsd-base)) + +(define %freebsd-native-development-profile-packages + (freebsd-native-development-profile-packages-for %default-freebsd-base)) + +(define %freebsd-core-packages %freebsd-host-staged-core-packages) +(define %freebsd-development-profile-packages %freebsd-host-staged-development-profile-packages) +(define %freebsd-system-packages %freebsd-host-staged-system-packages) diff --git a/modules/fruix/shepherd/freebsd.scm b/modules/fruix/shepherd/freebsd.scm new file mode 100644 index 0000000..a7a2194 --- /dev/null +++ b/modules/fruix/shepherd/freebsd.scm @@ -0,0 +1,104 @@ +(define-module (fruix shepherd freebsd) + #:use-module (shepherd service) + #:use-module (shepherd support) + #:use-module (ice-9 popen) + #:export (freebsd-rc-service + freebsd-loopback-alias-service + freebsd-tmpfs-service + freebsd-user-group-service)) + +(define (run-command program . args) + (let ((status (apply system* program args))) + (unless (zero? status) + (error "command failed" (cons program args) status)) + #t)) + +(define (run-command/ignore-errors program . args) + (apply system* program args) + #t) + +(define* (freebsd-rc-service provision script-name + #:key + (requirement '()) + (documentation + "Manage a FreeBSD rc.d service through 'service'.")) + (service provision + #:documentation documentation + #:requirement requirement + #:start (lambda _ + (run-command "/usr/sbin/service" script-name "onestart") + #t) + #:stop (lambda _ + (run-command "/usr/sbin/service" script-name "onestop") + #f) + #:respawn? #f)) + +(define* (freebsd-loopback-alias-service provision address + #:key + (interface "lo0") + (cidr "32") + (requirement '()) + (documentation + "Add and remove a loopback alias on FreeBSD.")) + (service provision + #:documentation documentation + #:requirement requirement + #:start (lambda _ + (run-command "/sbin/ifconfig" interface "alias" + (string-append address "/" cidr)) + #t) + #:stop (lambda _ + (run-command "/sbin/ifconfig" interface "-alias" address) + #f) + #:respawn? #f)) + +(define* (freebsd-tmpfs-service provision mount-point + #:key + (size "1m") + (mode "0750") + (requirement '()) + (documentation + "Mount and unmount a tmpfs filesystem on FreeBSD.")) + (service provision + #:documentation documentation + #:requirement requirement + #:start (lambda _ + (run-command "/bin/mkdir" "-p" mount-point) + (run-command "/sbin/mount" "-t" "tmpfs" + "-o" (string-append "size=" size ",mode=" mode) + "tmpfs" mount-point) + #t) + #:stop (lambda _ + (run-command "/sbin/umount" mount-point) + #f) + #:respawn? #f)) + +(define* (freebsd-user-group-service provision user group + #:key + uid + gid + home + (shell "/usr/sbin/nologin") + (comment "Fruix Shepherd prototype account") + (requirement '()) + (documentation + "Create and remove a temporary FreeBSD user/group pair.")) + (service provision + #:documentation documentation + #:requirement requirement + #:start (lambda _ + (run-command "/usr/sbin/pw" "groupadd" group + "-g" (number->string gid)) + (run-command "/usr/sbin/pw" "useradd" user + "-u" (number->string uid) + "-g" group + "-d" home + "-m" + "-s" shell + "-c" comment) + #t) + #:stop (lambda _ + (run-command/ignore-errors "/usr/sbin/pw" "userdel" user "-r") + (run-command/ignore-errors "/usr/sbin/pw" "groupdel" group) + #f) + #:respawn? #f)) diff --git a/modules/fruix/system/freebsd.scm b/modules/fruix/system/freebsd.scm new file mode 100644 index 0000000..4551483 --- /dev/null +++ b/modules/fruix/system/freebsd.scm @@ -0,0 +1,87 @@ +(define-module (fruix system freebsd) + #:use-module (fruix system freebsd model) + #:use-module (fruix system freebsd source) + #:use-module (fruix system freebsd executor) + #:use-module (fruix system freebsd build) + #: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? + promoted-native-build-result? + promoted-native-build-result-store-path + promoted-native-build-result-metadata-file + promoted-native-build-result-metadata + promoted-native-build-result-spec + operating-system + operating-system? + operating-system-host-name + operating-system-freebsd-base + operating-system-native-build-result + operating-system-kernel + operating-system-bootloader + operating-system-base-packages + operating-system-development-packages + operating-system-build-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 + native-build-executor + native-build-executor? + native-build-executor-ref + native-build-executor-kind + native-build-executor-name + native-build-executor-version + native-build-executor-properties + normalize-native-build-executor + host-native-build-executor + ssh-guest-native-build-executor + self-hosted-native-build-executor + promoted-native-build-result + promoted-native-build-result->freebsd-base + promoted-native-build-result-artifact-store + promoted-native-build-result-kernel-package + promoted-native-build-result-bootloader-package + promoted-native-build-result-base-packages + promoted-native-build-result-development-packages + operating-system-from-promoted-native-build-result + promote-native-build-result + operating-system-closure-spec + operating-system-install-spec + operating-system-image-spec + operating-system-installer-image-spec + operating-system-installer-iso-spec + installer-operating-system + materialize-operating-system + materialize-rootfs + install-operating-system + materialize-bhyve-image + materialize-installer-image + materialize-installer-iso + 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..f4a3294 --- /dev/null +++ b/modules/fruix/system/freebsd/build.scm @@ -0,0 +1,936 @@ +(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 executor) + #: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 + promoted-native-build-result + promoted-native-build-result->freebsd-base + promoted-native-build-result-artifact-store + promoted-native-build-result-kernel-package + promoted-native-build-result-bootloader-package + promoted-native-build-result-base-packages + promoted-native-build-result-development-packages + operating-system-from-promoted-native-build-result + materialize-freebsd-package + promote-native-build-result + 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-" + (sha256-string (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) "-" (sha256-string 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) + (sha256-string (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) + (if (existing-store-package? package) + (validate-existing-store-package package) + (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 (sha256-string manifest)) + (cached (hash-ref cache cache-key #f))) + (if cached + cached + (let* ((display-name (string-append (freebsd-package-name prepared-package) + "-" + (freebsd-package-version prepared-package))) + (output-path (make-store-path store-dir display-name manifest + #:kind 'freebsd-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 native-build-result-promotion-version "1") + +(define (native-build-result-ref data key default) + (match (assoc key data) + ((_ . value) value) + (#f default))) + +(define (native-build-result-executor result) + (let* ((executor (native-build-result-ref result 'executor #f)) + (legacy-version (native-build-result-ref result 'executor-version "legacy"))) + (cond + ((native-build-executor? executor) + executor) + ((string? executor) + (let ((normalized (normalize-native-build-executor executor))) + `((kind . ,(native-build-executor-kind normalized)) + (name . ,(native-build-executor-name normalized)) + (version . ,legacy-version) + (properties . ,(native-build-executor-properties normalized))))) + (else + (native-build-executor #:kind 'unknown + #:name "unknown" + #:version legacy-version))))) + +(define (native-build-result-executor-kind result) + (native-build-executor-kind (native-build-result-executor result))) + +(define (native-build-result-executor-name result) + (native-build-executor-name (native-build-result-executor result))) + +(define (native-build-result-executor-version result) + (native-build-executor-version (native-build-result-executor result))) + +(define (read-native-build-result result-root) + (let ((promotion-file (string-append result-root "/promotion.scm"))) + (unless (file-exists? promotion-file) + (error "native build result is missing promotion.scm" result-root)) + (let ((result (call-with-input-file promotion-file read))) + (unless (equal? (native-build-result-ref result 'native-build-result-version #f) + native-build-result-promotion-version) + (error "unsupported native build result promotion version" promotion-file)) + result))) + +(define existing-store-package-build-system 'existing-store-item-build-system) + +(define (existing-store-package? package) + (eq? (freebsd-package-build-system package) + existing-store-package-build-system)) + +(define (existing-store-package-ref package key default) + (build-plan-ref (freebsd-package-install-plan package) key default)) + +(define (validate-existing-store-package package) + (let* ((store-path (existing-store-package-ref package 'store-path #f)) + (required-file (existing-store-package-ref package 'required-file #f)) + (metadata-file (existing-store-package-ref package 'metadata-file #f))) + (unless (and (string? store-path) (file-exists? store-path)) + (error "existing-store package is missing a valid store path" package store-path)) + (when metadata-file + (unless (file-exists? metadata-file) + (error "existing-store package metadata file is missing" package metadata-file))) + (when required-file + (unless (file-exists? (string-append store-path "/" required-file)) + (error "existing-store package is missing required file" + package + (string-append store-path "/" required-file)))) + store-path)) + +(define (normalize-promoted-native-build-result value) + (cond + ((promoted-native-build-result? value) + value) + ((string? value) + (promoted-native-build-result #:store-path value)) + (else + (error "expected a promoted native build result or store path" value)))) + +(define (read-promoted-native-build-artifact-metadata metadata-file) + (unless (file-exists? metadata-file) + (error "promoted native build artifact metadata file is missing" metadata-file)) + (let ((metadata (call-with-input-file metadata-file read))) + (unless (equal? (native-build-result-ref metadata 'native-build-object-version #f) + native-build-result-promotion-version) + (error "unsupported promoted native build object version" metadata-file)) + (unless (eq? (native-build-result-ref metadata 'object-kind #f) 'artifact) + (error "promoted native build object is not an artifact" metadata-file)) + metadata)) + +(define (promoted-native-build-result-artifact-entry result artifact-kind) + (let* ((metadata (promoted-native-build-result-metadata result)) + (artifacts (native-build-result-ref metadata 'artifacts '())) + (entry (find (lambda (item) + (eq? (native-build-result-ref item 'artifact-kind #f) + artifact-kind)) + artifacts))) + (unless entry + (error "promoted native build result is missing artifact entry" artifact-kind)) + entry)) + +(define (promoted-native-build-result-artifact-store result artifact-kind) + (let* ((result (normalize-promoted-native-build-result result)) + (entry (promoted-native-build-result-artifact-entry result artifact-kind)) + (store-path (native-build-result-ref entry 'store-path #f)) + (metadata-file (native-build-result-ref entry 'metadata-file #f)) + (artifact-metadata (and metadata-file + (read-promoted-native-build-artifact-metadata metadata-file))) + (required-file (and artifact-metadata + (native-build-result-ref artifact-metadata 'required-file #f)))) + (unless (and (string? store-path) (file-exists? store-path)) + (error "promoted native build result is missing artifact store" artifact-kind store-path)) + (when artifact-metadata + (unless (eq? (native-build-result-ref artifact-metadata 'artifact-kind #f) + artifact-kind) + (error "promoted native build artifact metadata kind mismatch" + artifact-kind + metadata-file))) + (when required-file + (unless (file-exists? (string-append store-path "/" required-file)) + (error "promoted native build artifact store is missing required file" + artifact-kind + (string-append store-path "/" required-file)))) + store-path)) + +(define* (promoted-native-build-result #:key store-path) + (unless (and (string? store-path) (file-exists? store-path)) + (error "promoted native build result store path does not exist" store-path)) + (let* ((metadata-file (string-append store-path "/.fruix-native-build-result.scm"))) + (unless (file-exists? metadata-file) + (error "promoted native build result store is missing metadata" metadata-file)) + (let* ((metadata (call-with-input-file metadata-file read)) + (result (make-promoted-native-build-result store-path metadata-file metadata))) + (unless (equal? (native-build-result-ref metadata 'native-build-result-version #f) + native-build-result-promotion-version) + (error "unsupported promoted native build result version" metadata-file)) + (unless (eq? (native-build-result-ref metadata 'object-kind #f) 'result-bundle) + (error "promoted native build result store does not contain a result bundle" metadata-file)) + (for-each (lambda (artifact-kind) + (promoted-native-build-result-artifact-store result artifact-kind)) + '(world kernel headers bootloader)) + result))) + +(define (promoted-native-build-result->freebsd-base result) + (let* ((result (normalize-promoted-native-build-result result)) + (metadata (promoted-native-build-result-metadata result)) + (base (native-build-result-ref metadata 'freebsd-base '())) + (source (native-build-result-ref metadata 'source '())) + (source-root (or (native-build-result-ref source 'source-root #f) + (native-build-result-ref base 'source-root #f) + "/usr/src")) + (source-name (string-append "promoted-native-build-result-source-" + (path-basename + (promoted-native-build-result-store-path result)))) + (synthetic-source (freebsd-source #:name source-name + #:kind 'local-tree + #:path source-root))) + (freebsd-base #:name (native-build-result-ref base 'name "promoted-native-build-result") + #:version-label (native-build-result-ref base 'version-label "unknown") + #:release (native-build-result-ref base 'release "unknown") + #:branch (native-build-result-ref base 'branch "unknown") + #:source synthetic-source + #:source-root (native-build-result-ref base 'source-root source-root) + #:target (native-build-result-ref base 'target "amd64") + #:target-arch (native-build-result-ref base 'target-arch "amd64") + #:kernconf (native-build-result-ref base 'kernconf "GENERIC")))) + +(define (promoted-native-build-result-artifact-package result artifact-kind + package-name synopsis description) + (let* ((result (normalize-promoted-native-build-result result)) + (metadata (promoted-native-build-result-metadata result)) + (base (native-build-result-ref metadata 'freebsd-base '())) + (entry (promoted-native-build-result-artifact-entry result artifact-kind)) + (store-path (promoted-native-build-result-artifact-store result artifact-kind)) + (metadata-file (native-build-result-ref entry 'metadata-file #f)) + (artifact-metadata (and metadata-file + (read-promoted-native-build-artifact-metadata metadata-file))) + (required-file (and artifact-metadata + (native-build-result-ref artifact-metadata 'required-file #f)))) + (freebsd-package + #:name package-name + #:version (native-build-result-ref base 'version-label "unknown") + #:build-system existing-store-package-build-system + #:home-page "https://www.freebsd.org/" + #:synopsis synopsis + #:description description + #:license 'bsd-2 + #:install-plan `((store-path . ,store-path) + (metadata-file . ,metadata-file) + (required-file . ,required-file) + (artifact-kind . ,artifact-kind) + (result-store . ,(promoted-native-build-result-store-path result)))))) + +(define (promoted-native-build-result-world-package result) + (promoted-native-build-result-artifact-package + result + 'world + "freebsd-promoted-world" + "Promoted Fruix-native FreeBSD world artifact" + "FreeBSD world artifact imported from a promoted Fruix native-build result bundle.")) + +(define (promoted-native-build-result-kernel-package result) + (promoted-native-build-result-artifact-package + result + 'kernel + "freebsd-promoted-kernel" + "Promoted Fruix-native FreeBSD kernel artifact" + "FreeBSD kernel artifact imported from a promoted Fruix native-build result bundle.")) + +(define (promoted-native-build-result-bootloader-package result) + (promoted-native-build-result-artifact-package + result + 'bootloader + "freebsd-promoted-bootloader" + "Promoted Fruix-native FreeBSD bootloader artifact" + "FreeBSD bootloader artifact imported from a promoted Fruix native-build result bundle.")) + +(define (promoted-native-build-result-headers-package result) + (promoted-native-build-result-artifact-package + result + 'headers + "freebsd-promoted-headers" + "Promoted Fruix-native FreeBSD headers artifact" + "FreeBSD headers artifact imported from a promoted Fruix native-build result bundle.")) + +(define (promoted-native-build-result-base-packages result) + (list (promoted-native-build-result-world-package result))) + +(define (promoted-native-build-result-development-packages result) + (list (promoted-native-build-result-headers-package result))) + +(define* (operating-system-from-promoted-native-build-result result + #:key + (host-name #f) + (freebsd-base #f) + (kernel #f) + (bootloader #f) + (base-packages #f) + (development-packages #f) + (build-packages #f) + (users #f) + (groups #f) + (file-systems #f) + (services #f) + (loader-entries #f) + (rc-conf-entries #f) + (init-mode #f) + (ready-marker #f) + (root-authorized-keys #f)) + (let* ((result (normalize-promoted-native-build-result result)) + (defaults default-minimal-operating-system) + (fallback (lambda (value thunk) + (if (eq? value #f) (thunk) value)))) + (operating-system + #:host-name (fallback host-name (lambda () (operating-system-host-name defaults))) + #:freebsd-base (fallback freebsd-base (lambda () + (promoted-native-build-result->freebsd-base result))) + #:native-build-result result + #:kernel (fallback kernel (lambda () + (promoted-native-build-result-kernel-package result))) + #:bootloader (fallback bootloader (lambda () + (promoted-native-build-result-bootloader-package result))) + #:base-packages (fallback base-packages (lambda () + (promoted-native-build-result-base-packages result))) + #:development-packages (fallback development-packages (lambda () + (operating-system-development-packages defaults))) + #:build-packages (fallback build-packages (lambda () + (operating-system-build-packages defaults))) + #:users (fallback users (lambda () (operating-system-users defaults))) + #:groups (fallback groups (lambda () (operating-system-groups defaults))) + #:file-systems (fallback file-systems (lambda () (operating-system-file-systems defaults))) + #:services (fallback services (lambda () (operating-system-services defaults))) + #:loader-entries (fallback loader-entries (lambda () (operating-system-loader-entries defaults))) + #:rc-conf-entries (fallback rc-conf-entries (lambda () (operating-system-rc-conf-entries defaults))) + #:init-mode (fallback init-mode (lambda () (operating-system-init-mode defaults))) + #:ready-marker (fallback ready-marker (lambda () (operating-system-ready-marker defaults))) + #:root-authorized-keys (fallback root-authorized-keys (lambda () + (operating-system-root-authorized-keys defaults)))))) + +(define (native-build-artifact-entry result artifact-kind) + (let* ((artifacts (native-build-result-ref result 'artifacts '())) + (entry (assoc artifact-kind artifacts))) + (unless entry + (error "native build result is missing artifact entry" artifact-kind)) + (cdr entry))) + +(define (native-build-artifact-root result-root result artifact-kind) + (let* ((entry (native-build-artifact-entry result artifact-kind)) + (relative-path (native-build-result-ref entry 'path #f)) + (required-file (native-build-result-ref entry 'required-file #f)) + (artifact-root (and relative-path + (string-append result-root "/" relative-path)))) + (unless (and artifact-root (file-exists? artifact-root)) + (error "native build result is missing artifact tree" artifact-kind artifact-root)) + (when required-file + (unless (file-exists? (string-append artifact-root "/" required-file)) + (error "native build artifact is missing required file" + artifact-kind + (string-append artifact-root "/" required-file)))) + artifact-root)) + +(define (native-build-existing-store-references result store-dir) + (filter identity + (map (lambda (path) + (and (string? path) + (string-prefix? (string-append store-dir "/") path) + (file-exists? path) + path)) + (list (native-build-result-ref result 'closure-path #f) + (let ((source (native-build-result-ref result 'source '()))) + (native-build-result-ref source 'store-path #f)))))) + +(define (native-build-artifact-display-name result artifact-kind) + (let* ((base (native-build-result-ref result 'freebsd-base '())) + (version-label (native-build-result-ref base 'version-label "unknown")) + (executor-name (native-build-result-executor-name result))) + (string-append "fruix-native-" + (symbol->string artifact-kind) + "-" + version-label + "-" + executor-name))) + +(define (native-build-promoted-artifact-metadata result artifact-kind content-signature) + (let* ((entry (native-build-artifact-entry result artifact-kind)) + (executor (native-build-result-executor result)) + (build-profile (native-build-result-ref result 'build-profile + (native-build-result-ref result 'development-profile "")))) + `((native-build-object-version . ,native-build-result-promotion-version) + (object-kind . artifact) + (artifact-kind . ,artifact-kind) + (executor . ,executor) + (executor-kind . ,(native-build-result-executor-kind result)) + (executor-name . ,(native-build-result-executor-name result)) + (executor-version . ,(native-build-result-executor-version result)) + (run-id . ,(native-build-result-ref result 'run-id "unknown")) + (guest-host-name . ,(native-build-result-ref result 'guest-host-name "unknown")) + (closure-path . ,(native-build-result-ref result 'closure-path "")) + (development-profile . ,(native-build-result-ref result 'development-profile "")) + (build-profile . ,build-profile) + (freebsd-base . ,(native-build-result-ref result 'freebsd-base '())) + (source . ,(native-build-result-ref result 'source '())) + (build-policy . ,(native-build-result-ref result 'build-policy '())) + (required-file . ,(native-build-result-ref entry 'required-file "")) + (recorded-sha256 . ,(native-build-result-ref entry 'recorded-sha256 "")) + (content-signature . ,content-signature)))) + +(define (promote-native-build-artifact result-root result store-dir artifact-kind) + (let* ((artifact-root (native-build-artifact-root result-root result artifact-kind)) + (content-signature (tree-content-signature artifact-root)) + (metadata (native-build-promoted-artifact-metadata result artifact-kind content-signature)) + (payload (object->string metadata)) + (display-name (native-build-artifact-display-name result artifact-kind)) + (output-path (make-store-path store-dir display-name payload + #:kind 'native-build-artifact + #:output artifact-kind)) + (references (native-build-existing-store-references result store-dir))) + (unless (file-exists? output-path) + (mkdir-p output-path) + (stage-tree-into-output artifact-root output-path) + (write-file (string-append output-path "/.references") + (string-join references "\n")) + (write-file (string-append output-path "/.fruix-native-build-object.scm") + payload)) + `((artifact-kind . ,artifact-kind) + (artifact-root . ,artifact-root) + (store-path . ,output-path) + (content-signature . ,content-signature) + (metadata-file . ,(string-append output-path "/.fruix-native-build-object.scm")))) ) + +(define (native-build-result-display-name result) + (let* ((base (native-build-result-ref result 'freebsd-base '())) + (version-label (native-build-result-ref base 'version-label "unknown")) + (executor-name (native-build-result-executor-name result))) + (string-append "fruix-native-build-result-" version-label "-" executor-name))) + +(define (native-build-promoted-result-object result promoted-artifacts) + (let ((executor (native-build-result-executor result)) + (build-profile (native-build-result-ref result 'build-profile + (native-build-result-ref result 'development-profile "")))) + `((native-build-result-version . ,native-build-result-promotion-version) + (object-kind . result-bundle) + (executor . ,executor) + (executor-kind . ,(native-build-result-executor-kind result)) + (executor-name . ,(native-build-result-executor-name result)) + (executor-version . ,(native-build-result-executor-version result)) + (run-id . ,(native-build-result-ref result 'run-id "unknown")) + (guest-host-name . ,(native-build-result-ref result 'guest-host-name "unknown")) + (closure-path . ,(native-build-result-ref result 'closure-path "")) + (development-profile . ,(native-build-result-ref result 'development-profile "")) + (build-profile . ,build-profile) + (freebsd-base . ,(native-build-result-ref result 'freebsd-base '())) + (source . ,(native-build-result-ref result 'source '())) + (build-policy . ,(native-build-result-ref result 'build-policy '())) + (artifact-count . ,(length promoted-artifacts)) + (artifacts . ,(map (lambda (entry) + `((artifact-kind . ,(assoc-ref entry 'artifact-kind)) + (store-path . ,(assoc-ref entry 'store-path)) + (content-signature . ,(assoc-ref entry 'content-signature)) + (metadata-file . ,(assoc-ref entry 'metadata-file)))) + promoted-artifacts))))) + +(define* (promote-native-build-result result-root #:key (store-dir "/frx/store")) + (let* ((result (read-native-build-result result-root)) + (promoted-artifacts (map (lambda (artifact-kind) + (promote-native-build-artifact result-root result store-dir artifact-kind)) + '(world kernel headers bootloader))) + (result-object (native-build-promoted-result-object result promoted-artifacts)) + (payload (object->string result-object)) + (display-name (native-build-result-display-name result)) + (result-store (make-store-path store-dir display-name payload + #:kind 'native-build-result)) + (result-references (append (map (lambda (entry) + (assoc-ref entry 'store-path)) + promoted-artifacts) + (native-build-existing-store-references result store-dir)))) + (unless (file-exists? result-store) + (mkdir-p (string-append result-store "/artifacts")) + (for-each (lambda (entry) + (symlink (assoc-ref entry 'store-path) + (string-append result-store + "/artifacts/" + (symbol->string (assoc-ref entry 'artifact-kind))))) + promoted-artifacts) + (write-file (string-append result-store "/.references") + (string-join result-references "\n")) + (write-file (string-append result-store "/.fruix-native-build-result.scm") + payload)) + `((result-root . ,result-root) + (executor-kind . ,(native-build-result-executor-kind result)) + (executor-name . ,(native-build-result-executor-name result)) + (executor-version . ,(native-build-result-executor-version result)) + (result-store . ,result-store) + (result-metadata-file . ,(string-append result-store "/.fruix-native-build-result.scm")) + (artifact-store-count . ,(length promoted-artifacts)) + (artifact-stores . ,(map (lambda (entry) (assoc-ref entry 'store-path)) promoted-artifacts)) + (world-store . ,(assoc-ref (find (lambda (entry) + (eq? (assoc-ref entry 'artifact-kind) 'world)) + promoted-artifacts) + 'store-path)) + (kernel-store . ,(assoc-ref (find (lambda (entry) + (eq? (assoc-ref entry 'artifact-kind) 'kernel)) + promoted-artifacts) + 'store-path)) + (headers-store . ,(assoc-ref (find (lambda (entry) + (eq? (assoc-ref entry 'artifact-kind) 'headers)) + promoted-artifacts) + 'store-path)) + (bootloader-store . ,(assoc-ref (find (lambda (entry) + (eq? (assoc-ref entry 'artifact-kind) 'bootloader)) + promoted-artifacts) + 'store-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-materializer-version "3") + +(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)) + (display-name (string-append name "-" version)) + (output-path (make-store-path store-dir display-name manifest + #:kind 'prefix))) + (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/executor.scm b/modules/fruix/system/freebsd/executor.scm new file mode 100644 index 0000000..32c5958 --- /dev/null +++ b/modules/fruix/system/freebsd/executor.scm @@ -0,0 +1,121 @@ +(define-module (fruix system freebsd executor) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:export (native-build-executor-model-version + native-build-executor + native-build-executor? + native-build-executor-ref + native-build-executor-kind + native-build-executor-name + native-build-executor-version + native-build-executor-properties + normalize-native-build-executor + host-native-build-executor + ssh-guest-native-build-executor + self-hosted-native-build-executor)) + +(define native-build-executor-model-version "1") + +(define (association-list? value) + (and (list? value) + (every pair? value))) + +(define (executor-name kind provided-name) + (or provided-name + (symbol->string kind))) + +(define* (native-build-executor #:key kind name + (version native-build-executor-model-version) + (properties '())) + (unless (symbol? kind) + (error "native build executor kind must be a symbol" kind)) + (unless (string? (executor-name kind name)) + (error "native build executor name must be a string" name)) + (unless (string? version) + (error "native build executor version must be a string" version)) + (unless (association-list? properties) + (error "native build executor properties must be an association list" properties)) + `((kind . ,kind) + (name . ,(executor-name kind name)) + (version . ,version) + (properties . ,properties))) + +(define (native-build-executor-ref executor key default) + (match (assoc key executor) + ((_ . value) value) + (#f default))) + +(define (native-build-executor? value) + (and (association-list? value) + (symbol? (native-build-executor-ref value 'kind #f)) + (string? (native-build-executor-ref value 'name #f)) + (string? (native-build-executor-ref value 'version #f)) + (association-list? (native-build-executor-ref value 'properties '())))) + +(define (native-build-executor-kind executor) + (native-build-executor-ref executor 'kind 'unknown)) + +(define (native-build-executor-name executor) + (native-build-executor-ref executor 'name "unknown")) + +(define (native-build-executor-version executor) + (native-build-executor-ref executor 'version "unknown")) + +(define (native-build-executor-properties executor) + (native-build-executor-ref executor 'properties '())) + +(define (legacy-executor-kind name) + (cond + ((member name '("host")) 'host) + ((member name '("ssh-guest" "guest-ssh" "guest-host-initiated")) 'ssh-guest) + ((member name '("self-hosted" "guest-self-hosted")) 'self-hosted) + ((member name '("jail")) 'jail) + ((member name '("remote-builder")) 'remote-builder) + (else 'legacy))) + +(define (normalize-native-build-executor value) + (cond + ((native-build-executor? value) + value) + ((string? value) + (native-build-executor #:kind (legacy-executor-kind value) + #:name value + #:version "legacy")) + (else + (error "unsupported native build executor representation" value)))) + +(define* (host-native-build-executor #:key (name "host") + host-name working-directory) + (native-build-executor + #:kind 'host + #:name name + #:properties (filter-map identity + `((host-name . ,host-name) + (working-directory . ,working-directory))))) + +(define* (ssh-guest-native-build-executor #:key (name "ssh-guest") + transport orchestrator + guest-host-name guest-ip vm-id vdi-id) + (native-build-executor + #:kind 'ssh-guest + #:name name + #:properties (filter-map identity + `((transport . ,(or transport "ssh")) + (orchestrator . ,(or orchestrator "host")) + (guest-host-name . ,guest-host-name) + (guest-ip . ,guest-ip) + (vm-id . ,vm-id) + (vdi-id . ,vdi-id))))) + +(define* (self-hosted-native-build-executor #:key (name "self-hosted") + helper-path helper-version + guest-host-name build-root-base result-root-base) + (native-build-executor + #:kind 'self-hosted + #:name name + #:version (or helper-version native-build-executor-model-version) + #:properties (filter-map identity + `((helper-path . ,helper-path) + (guest-host-name . ,guest-host-name) + (build-root-base . ,build-root-base) + (result-root-base . ,result-root-base))))) diff --git a/modules/fruix/system/freebsd/media.scm b/modules/fruix/system/freebsd/media.scm new file mode 100644 index 0000000..29949a4 --- /dev/null +++ b/modules/fruix/system/freebsd/media.scm @@ -0,0 +1,1627 @@ +(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) + #:use-module (rnrs io ports) + #:export (operating-system-install-spec + operating-system-image-spec + operating-system-installer-image-spec + operating-system-installer-iso-spec + installer-operating-system + materialize-operating-system + materialize-rootfs + install-operating-system + materialize-bhyve-image + materialize-installer-image + materialize-installer-iso)) + +(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") + (guile-store-path #f) + (guile-extra-store-path #f) + (shepherd-store-path #f) + (declaration-source #f) + (declaration-origin #f) + (declaration-system-symbol #f)) + (validate-operating-system os) + (let* ((cache (make-hash-table)) + (source-cache (make-hash-table)) + (native-build-result (operating-system-native-build-result os)) + (kernel-package (operating-system-kernel os)) + (bootloader-package (operating-system-bootloader os)) + (base-packages (operating-system-base-packages os)) + (development-packages (operating-system-development-packages os)) + (build-packages (operating-system-build-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)) + (development-package-stores + (map (lambda (package) + (materialize-freebsd-package package store-dir cache source-cache)) + development-packages)) + (build-package-stores + (map (lambda (package) + (materialize-freebsd-package package store-dir cache source-cache)) + build-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 (or guile-store-path + (materialize-prefix guile-prefix "fruix-guile-runtime" "3.0" store-dir + #:extra-files guile-runtime-extra-files))) + (guile-extra-store (or guile-extra-store-path + (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 (or shepherd-store-path + (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))) + (promoted-native-build-result-summary + (and native-build-result + (promoted-native-build-result-spec native-build-result))) + (promoted-native-build-result-store + (and native-build-result + (promoted-native-build-result-store-path native-build-result))) + (promoted-native-build-artifact-stores + (delete-duplicates + (filter identity + (if native-build-result + (map (lambda (artifact-kind) + (promoted-native-build-result-artifact-store native-build-result artifact-kind)) + '(world kernel headers bootloader)) + '())))) + (declaration-source-text + (or declaration-source + ";; Fruix declaration source is unavailable for this closure.\n")) + (declaration-origin-text (or declaration-origin "")) + (declaration-system-text + (cond ((symbol? declaration-system-symbol) + (symbol->string declaration-system-symbol)) + ((string? declaration-system-symbol) + declaration-system-symbol) + (else ""))) + (declaration-info-object + `((available? . ,(not (not declaration-source))) + (system-variable . ,declaration-system-text))) + (metadata-files + (append + (list (cons "metadata/freebsd-base.scm" + (object->string (freebsd-base-spec (operating-system-freebsd-base os)))) + (cons "metadata/freebsd-source.scm" + (object->string (freebsd-source-spec (freebsd-base-source (operating-system-freebsd-base os))))) + (cons "metadata/freebsd-source-materializations.scm" + (object->string (map freebsd-source-materialization-spec source-materializations))) + (cons "metadata/host-base-provenance.scm" + (object->string (host-freebsd-provenance))) + (cons "metadata/system-declaration.scm" + declaration-source-text) + (cons "metadata/system-declaration-info.scm" + (object->string declaration-info-object)) + (cons "metadata/system-declaration-system" + (string-append declaration-system-text "\n")) + (cons "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)))) + (system-declaration-available? . ,(not (not declaration-source))) + (system-declaration-system-variable . ,declaration-system-text) + (promoted-native-build-result . ,promoted-native-build-result-summary) + (promoted-native-build-artifact-store-count . ,(length promoted-native-build-artifact-stores)) + (promoted-native-build-artifact-stores . ,promoted-native-build-artifact-stores) + (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) + (development-package-store-count . ,(length development-package-stores)) + (development-package-stores . ,development-package-stores) + (build-package-store-count . ,(length build-package-stores)) + (build-package-stores . ,build-package-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)))))) + (if promoted-native-build-result-summary + (list (cons "metadata/promoted-native-build-result.scm" + (object->string promoted-native-build-result-summary))) + '()))) + (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 (if promoted-native-build-result-store + (list promoted-native-build-result-store) + '()) + materialized-source-stores + host-base-stores + native-base-stores + development-package-stores + build-package-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"))) + (display-name (string-append "fruix-system-" + (operating-system-host-name os))) + (closure-path (make-store-path store-dir display-name manifest + #:kind 'operating-system)) + (development-profile-path (and (not (null? development-package-stores)) + (string-append closure-path "/development-profile"))) + (build-profile-path (and (not (null? build-package-stores)) + (string-append closure-path "/build-profile")))) + (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) + (when development-profile-path + (mkdir-p development-profile-path) + (for-each (lambda (output) + (merge-output-into-tree output development-profile-path)) + development-package-stores)) + (when build-profile-path + (mkdir-p build-profile-path) + (for-each (lambda (output) + (merge-output-into-tree output build-profile-path)) + build-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 "/usr/local/bin/fruix")) + (chmod (string-append closure-path "/usr/local/bin/fruix") #o555)) + (when (file-exists? (string-append closure-path "/usr/local/bin/fruix-development-environment")) + (chmod (string-append closure-path "/usr/local/bin/fruix-development-environment") #o555)) + (when (file-exists? (string-append closure-path "/usr/local/bin/fruix-build-environment")) + (chmod (string-append closure-path "/usr/local/bin/fruix-build-environment") #o555)) + (when (file-exists? (string-append closure-path "/usr/local/bin/fruix-self-hosted-native-build")) + (chmod (string-append closure-path "/usr/local/bin/fruix-self-hosted-native-build") #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) + (development-package-stores . ,development-package-stores) + (build-package-stores . ,build-package-stores) + (development-profile-path . ,development-profile-path) + (build-profile-path . ,build-profile-path) + (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")) + (system-declaration-file . ,(string-append closure-path "/metadata/system-declaration.scm")) + (system-declaration-info-file . ,(string-append closure-path "/metadata/system-declaration-info.scm")) + (system-declaration-system-file . ,(string-append closure-path "/metadata/system-declaration-system")) + (store-layout-file . ,(string-append closure-path "/metadata/store-layout.scm")) + (promoted-native-build-result-file + . ,(and promoted-native-build-result-summary + (string-append closure-path "/metadata/promoted-native-build-result.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 system-generation-layout-version "2") + +(define* (system-generation-metadata-object os closure-path + #:key + (generation-number 1) + install-spec + install-metadata-path) + `((system-generation-version . ,system-generation-layout-version) + (generation-number . ,generation-number) + (host-name . ,(operating-system-host-name os)) + (ready-marker . ,(operating-system-ready-marker os)) + (init-mode . ,(operating-system-init-mode os)) + (closure-path . ,closure-path) + (parameters-file . ,(string-append closure-path "/parameters.scm")) + (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")) + (host-base-provenance-file . ,(string-append closure-path "/metadata/host-base-provenance.scm")) + (system-declaration-file . ,(string-append closure-path "/metadata/system-declaration.scm")) + (system-declaration-info-file . ,(string-append closure-path "/metadata/system-declaration-info.scm")) + (system-declaration-system-file . ,(string-append closure-path "/metadata/system-declaration-system")) + (store-layout-file . ,(string-append closure-path "/metadata/store-layout.scm")) + (install-metadata-path . ,install-metadata-path) + (install-spec . ,install-spec))) + +(define (system-generation-provenance-object closure-path) + `((closure-path . ,closure-path) + (parameters-file . ,(string-append closure-path "/parameters.scm")) + (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")) + (host-base-provenance-file . ,(string-append closure-path "/metadata/host-base-provenance.scm")) + (system-declaration-file . ,(string-append closure-path "/metadata/system-declaration.scm")) + (system-declaration-info-file . ,(string-append closure-path "/metadata/system-declaration-info.scm")) + (system-declaration-system-file . ,(string-append closure-path "/metadata/system-declaration-system")) + (store-layout-file . ,(string-append closure-path "/metadata/store-layout.scm")))) + +(define* (populate-system-generation-layout os rootfs closure-path + #:key + (generation-number 1) + install-spec + install-metadata-path) + (let* ((system-root (string-append rootfs "/var/lib/fruix/system")) + (generation-name (number->string generation-number)) + (generation-link-target (string-append "generations/" generation-name)) + (generation-dir (string-append system-root "/generations/" generation-name)) + (gcroots-dir (string-append rootfs "/frx/var/fruix/gcroots")) + (generation-install-file (string-append generation-dir "/install.scm")) + (root-install-file (and install-metadata-path + (string-append rootfs install-metadata-path)))) + (mkdir-p generation-dir) + (symlink-force closure-path (string-append generation-dir "/closure")) + (write-file (string-append generation-dir "/metadata.scm") + (object->string + (system-generation-metadata-object os closure-path + #:generation-number generation-number + #:install-spec install-spec + #:install-metadata-path install-metadata-path))) + (write-file (string-append generation-dir "/provenance.scm") + (object->string (system-generation-provenance-object closure-path))) + (when (and root-install-file (file-exists? root-install-file)) + (copy-regular-file root-install-file generation-install-file) + (chmod generation-install-file #o644)) + (symlink-force generation-link-target (string-append system-root "/current")) + (write-file (string-append system-root "/current-generation") + (string-append generation-name "\n")) + (mkdir-p gcroots-dir) + (symlink-force closure-path (string-append gcroots-dir "/system-" generation-name)) + (symlink-force closure-path (string-append gcroots-dir "/current-system")))) + +(define* (populate-rootfs-from-closure os rootfs closure-path + #:key + install-spec + install-metadata-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/bin" "/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/bin/fruix" + (string-append rootfs "/usr/local/bin/fruix")) + (when (file-exists? (string-append closure-path "/development-profile")) + (symlink-force "/run/current-system/development-profile" + (string-append rootfs "/run/current-development"))) + (when (file-exists? (string-append closure-path "/build-profile")) + (symlink-force "/run/current-system/build-profile" + (string-append rootfs "/run/current-build")) + (when (file-exists? (string-append closure-path "/build-profile/usr/include")) + (symlink-force "/run/current-system/build-profile/usr/include" + (string-append rootfs "/usr/include"))) + (when (file-exists? (string-append closure-path "/build-profile/usr/share/mk")) + (symlink-force "/run/current-system/build-profile/usr/share/mk" + (string-append rootfs "/usr/share/mk")))) + (when (and (not (file-exists? (string-append closure-path "/build-profile"))) + (file-exists? (string-append closure-path "/development-profile"))) + (when (file-exists? (string-append closure-path "/development-profile/usr/include")) + (symlink-force "/run/current-system/development-profile/usr/include" + (string-append rootfs "/usr/include"))) + (when (file-exists? (string-append closure-path "/development-profile/usr/share/mk")) + (symlink-force "/run/current-system/development-profile/usr/share/mk" + (string-append rootfs "/usr/share/mk")))) + (when (file-exists? (string-append closure-path "/usr/local/bin/fruix-development-environment")) + (symlink-force "/run/current-system/usr/local/bin/fruix-development-environment" + (string-append rootfs "/usr/local/bin/fruix-development-environment"))) + (when (file-exists? (string-append closure-path "/usr/local/bin/fruix-build-environment")) + (symlink-force "/run/current-system/usr/local/bin/fruix-build-environment" + (string-append rootfs "/usr/local/bin/fruix-build-environment"))) + (when (file-exists? (string-append closure-path "/usr/local/bin/fruix-self-hosted-native-build")) + (symlink-force "/run/current-system/usr/local/bin/fruix-self-hosted-native-build" + (string-append rootfs "/usr/local/bin/fruix-self-hosted-native-build"))) + (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")) + (populate-system-generation-layout os rootfs closure-path + #:install-spec install-spec + #:install-metadata-path install-metadata-path) + `((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") + (declaration-source #f) + (declaration-origin #f) + (declaration-system-symbol #f)) + (let* ((closure (materialize-operating-system os + #:store-dir store-dir + #:guile-prefix guile-prefix + #:guile-extra-prefix guile-extra-prefix + #:shepherd-prefix shepherd-prefix + #:declaration-source declaration-source + #:declaration-origin declaration-origin + #:declaration-system-symbol declaration-system-symbol)) + (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* (operating-system-installer-iso-spec os + #:key + (install-target-device "/dev/vtbd0") + (installer-host-name (string-append (operating-system-host-name os) + "-installer")) + (root-size #f) + (iso-volume-label "FRUIX_INSTALLER") + (installer-root-partition-label "fruix-installer-root") + (target-efi-partition-label "efiboot") + (target-root-partition-label "fruix-root") + (serial-console "comconsole")) + (let ((target-install-spec (operating-system-install-spec os + #:target install-target-device + #:target-kind 'block-device + #:efi-size "64m" + #: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) + (boot-mode . uefi) + (image-format . iso9660) + (iso-volume-label . ,iso-volume-label) + (root-size . ,root-size) + (installer-root-partition-label . ,installer-root-partition-label) + (target-install . ,target-install-spec)))) + +(define image-builder-version "3") +(define install-builder-version "2") +(define installer-image-builder-version "2") +(define installer-iso-builder-version "3") + +(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_root/var/lib/fruix/system/generations/1\" \"$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" + "cp \"$install_metadata_source\" \"$mnt_root/var/lib/fruix/system/generations/1/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") + (declaration-source #f) + (declaration-origin #f) + (declaration-system-symbol #f) + (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 + #:declaration-source declaration-source + #:declaration-origin declaration-origin + #:declaration-system-symbol declaration-system-symbol)) + (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 + #:install-spec install-spec + #:install-metadata-path install-metadata-relative-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) + (populate-system-generation-layout os mnt-root closure-path + #:install-spec install-spec + #:install-metadata-path install-metadata-relative-path)) + (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") + (declaration-source #f) + (declaration-origin #f) + (declaration-system-symbol #f) + (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 + #:declaration-source declaration-source + #:declaration-origin declaration-origin + #:declaration-system-symbol declaration-system-symbol)) + (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")) + (display-name (string-append "fruix-bhyve-image-" + (operating-system-host-name os))) + (image-store-path (make-store-path store-dir display-name manifest + #:kind 'bhyve-image)) + (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 + #:declaration-source declaration-source + #:declaration-origin declaration-origin + #:declaration-system-symbol declaration-system-symbol) + (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") + (declaration-source #f) + (declaration-origin #f) + (declaration-system-symbol #f) + (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 + #:declaration-source declaration-source + #:declaration-origin declaration-origin + #:declaration-system-symbol declaration-system-symbol)) + (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 + #:declaration-source declaration-source + #:declaration-origin declaration-origin + #:declaration-system-symbol declaration-system-symbol)) + (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")) + (display-name (string-append "fruix-installer-image-" + (operating-system-host-name installer-os))) + (image-store-path (make-store-path store-dir display-name manifest + #:kind 'installer-image)) + (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 + #:install-spec target-install-spec + #:install-metadata-path "/var/lib/fruix/install.scm") + (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)))) + +(define (resolved-path path) + (let ((target (false-if-exception (readlink path)))) + (if target + (if (string-prefix? "/" target) + target + (string-append (dirname path) "/" target)) + path))) + +(define (copy-resolved-node source destination) + (copy-node (resolved-path source) destination)) + +(define (sanitize-iso-volume-label label) + (let* ((text (if (and (string? label) (not (string-null? label))) + label + "FRUIX_INSTALLER")) + (upper (string-upcase text)) + (chars (map (lambda (ch) + (if (or (char-alphabetic? ch) + (char-numeric? ch) + (memv ch '(#\_ #\-))) + ch + #\_)) + (string->list upper))) + (sanitized (list->string chars))) + (if (> (string-length sanitized) 32) + (substring sanitized 0 32) + sanitized))) + +(define (source-store-item? item) + (string-contains (path-basename item) "-freebsd-source-")) + +(define (runtime-store-items items) + (filter (lambda (item) + (not (source-store-item? item))) + items)) + +(define (write-installer-iso-loader-conf source-path destination) + (let* ((mode (stat:perms (stat source-path))) + (base (call-with-input-file source-path get-string-all)) + (extra (string-append + "mdroot_load=\"YES\"\n" + "mdroot_type=\"mfs_root\"\n" + "mdroot_name=\"/boot/root.img\"\n" + "vfs.root.mountfrom=\"ufs:/dev/md0\"\n" + "vfs.root.mountfrom.options=\"rw\"\n"))) + (write-file destination + (string-append base + (if (or (string-null? base) + (char=? (string-ref base (- (string-length base) 1)) #\newline)) + "" + "\n") + extra)) + (chmod destination mode))) + +(define (rewrite-installer-iso-fstab image-rootfs installer-closure-path) + (let ((fstab-path (string-append image-rootfs "/frx/store/" + (path-basename installer-closure-path) + "/etc/fstab"))) + (rewrite-text-file fstab-path + '(("/dev/gpt/fruix-installer-root\t/\tufs" + . "/dev/md0\t/\tufs"))))) + +(define* (make-ufs-image output-path source-root label #:key size) + (apply run-command + (append (list "makefs" "-t" "ffs" "-T" "0" "-B" "little") + (if size + (list "-s" size) + '()) + (list "-o" (string-append "label=" label + ",version=2,bsize=32768,fsize=4096,density=16384") + output-path + source-root)))) + +(define (make-efi-boot-image loader-efi output-path) + (let ((stage-root (mktemp-directory "/tmp/fruix-installer-iso-esp.XXXXXX"))) + (dynamic-wind + (lambda () #t) + (lambda () + (mkdir-p (string-append stage-root "/EFI/BOOT")) + (copy-regular-file loader-efi + (string-append stage-root "/EFI/BOOT/BOOTX64.EFI")) + (run-command "makefs" "-t" "msdos" "-T" "0" + "-o" "fat_type=12" + "-o" "sectors_per_cluster=1" + "-o" "volume_label=EFISYS" + "-s" "2048k" + output-path stage-root)) + (lambda () + (when (file-exists? stage-root) + (delete-file-recursively stage-root)))))) + +(define (populate-installer-iso-boot-tree installer-closure-path iso-root root-image-path) + (let ((boot-root (string-append iso-root "/boot"))) + (mkdir-p (string-append boot-root "/kernel")) + (copy-resolved-node (string-append installer-closure-path "/boot/kernel/kernel") + (string-append boot-root "/kernel/kernel")) + (copy-resolved-node (string-append installer-closure-path "/boot/kernel/linker.hints") + (string-append boot-root "/kernel/linker.hints")) + (copy-resolved-node (string-append installer-closure-path "/boot/loader") + (string-append boot-root "/loader")) + (copy-resolved-node (string-append installer-closure-path "/boot/loader.efi") + (string-append boot-root "/loader.efi")) + (copy-resolved-node (string-append installer-closure-path "/boot/device.hints") + (string-append boot-root "/device.hints")) + (copy-resolved-node (string-append installer-closure-path "/boot/defaults") + (string-append boot-root "/defaults")) + (copy-resolved-node (string-append installer-closure-path "/boot/lua") + (string-append boot-root "/lua")) + (write-installer-iso-loader-conf (string-append installer-closure-path "/boot/loader.conf") + (string-append boot-root "/loader.conf")) + (copy-regular-file root-image-path + (string-append boot-root "/root.img")))) + +(define* (materialize-installer-iso 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") + (declaration-source #f) + (declaration-origin #f) + (declaration-system-symbol #f) + (install-target-device "/dev/vtbd0") + (root-size #f) + (installer-host-name (string-append (operating-system-host-name os) + "-installer")) + (installer-root-partition-label "fruix-installer-root") + (target-efi-partition-label "efiboot") + (target-root-partition-label "fruix-root") + (serial-console "comconsole") + (iso-volume-label "FRUIX_INSTALLER")) + (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 + #:declaration-source declaration-source + #:declaration-origin declaration-origin + #:declaration-system-symbol declaration-system-symbol)) + (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 + #:declaration-source declaration-source + #:declaration-origin declaration-origin + #:declaration-system-symbol declaration-system-symbol)) + (target-closure-path (assoc-ref target-closure 'closure-path)) + (installer-closure-path (assoc-ref installer-closure 'closure-path)) + (target-closure-store-items (store-reference-closure (list target-closure-path))) + (target-runtime-store-items (runtime-store-items target-closure-store-items)) + (installer-store-items (runtime-store-items + (store-reference-closure (list installer-closure-path)))) + (combined-store-items (delete-duplicates (append installer-store-items target-runtime-store-items))) + (sanitized-iso-volume-label (sanitize-iso-volume-label iso-volume-label)) + (installer-iso-spec (operating-system-installer-iso-spec os + #:install-target-device install-target-device + #:installer-host-name installer-host-name + #:root-size root-size + #:iso-volume-label sanitized-iso-volume-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)) + (target-install-spec (assoc-ref installer-iso-spec 'target-install)) + (install-metadata (operating-system-install-metadata-object target-install-spec + target-closure-path + target-closure-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-iso-builder-version=\n" + installer-iso-builder-version + "\ninstaller-iso-spec=\n" + (object->string installer-iso-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-closure-store-items "\n") + "\ninstall-metadata=\n" + (object->string install-metadata) + "\n")) + (display-name (string-append "fruix-installer-iso-" + (operating-system-host-name installer-os))) + (iso-store-path (make-store-path store-dir display-name manifest + #:kind 'installer-iso)) + (iso-image (string-append iso-store-path "/installer.iso")) + (boot-efi-image (string-append iso-store-path "/efiboot.img")) + (root-image (string-append iso-store-path "/root.img"))) + (unless (file-exists? iso-store-path) + (let* ((build-root (mktemp-directory "/tmp/fruix-installer-iso-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")) + (iso-root (string-append build-root "/iso-root")) + (temp-output (mktemp-directory (string-append store-dir "/.fruix-installer-iso.XXXXXX"))) + (temp-iso (string-append build-root "/installer.iso")) + (temp-esp (string-append build-root "/efiboot.img")) + (temp-root (string-append build-root "/root.img")) + (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 + #:install-spec target-install-spec + #:install-metadata-path "/var/lib/fruix/install.scm") + (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-runtime-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") "64m\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) + (rewrite-installer-iso-fstab image-rootfs installer-closure-path) + (make-ufs-image temp-root image-rootfs installer-root-partition-label #:size root-size) + (populate-installer-iso-boot-tree installer-closure-path iso-root temp-root) + (make-efi-boot-image (resolved-path (string-append installer-closure-path "/boot/loader.efi")) temp-esp) + (run-command "makefs" "-t" "cd9660" "-T" "0" + "-o" (string-append "bootimage=efi;" temp-esp) + "-o" "no-emul-boot" + "-o" "platformid=efi" + "-o" "rockridge" + "-o" (string-append "label=" sanitized-iso-volume-label) + temp-iso iso-root) + (mkdir-p temp-output) + (copy-regular-file temp-iso (string-append temp-output "/installer.iso")) + (copy-regular-file temp-esp (string-append temp-output "/efiboot.img")) + (copy-regular-file temp-root (string-append temp-output "/root.img")) + (write-file (string-append temp-output "/installer-iso-spec.scm") + (object->string installer-iso-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 "/installer.iso") + (string-append temp-output "/efiboot.img") + (string-append temp-output "/root.img") + (string-append temp-output "/installer-iso-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 iso-store-path)) + (lambda () + (when (file-exists? build-root) + (delete-file-recursively build-root)))))) + `((iso-store-path . ,iso-store-path) + (iso-image . ,iso-image) + (boot-efi-image . ,boot-efi-image) + (root-image . ,root-image) + (installer-closure-path . ,installer-closure-path) + (target-closure-path . ,target-closure-path) + (closure-path . ,installer-closure-path) + (installer-iso-spec . ,installer-iso-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-closure-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..cea69a4 --- /dev/null +++ b/modules/fruix/system/freebsd/model.scm @@ -0,0 +1,446 @@ +(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? + make-promoted-native-build-result + promoted-native-build-result? + promoted-native-build-result-store-path + promoted-native-build-result-metadata-file + promoted-native-build-result-metadata + promoted-native-build-result-spec + operating-system + operating-system? + operating-system-host-name + operating-system-freebsd-base + operating-system-native-build-result + operating-system-kernel + operating-system-bootloader + operating-system-base-packages + operating-system-development-packages + operating-system-build-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-promoted-native-build-result store-path metadata-file metadata) + promoted-native-build-result? + (store-path promoted-native-build-result-store-path) + (metadata-file promoted-native-build-result-metadata-file) + (metadata promoted-native-build-result-metadata)) + +(define (promoted-native-build-result-metadata-ref metadata key default) + (match (assoc key metadata) + ((_ . value) value) + (#f default))) + +(define (promoted-native-build-result-artifact-spec metadata artifact-kind) + (find (lambda (entry) + (eq? (promoted-native-build-result-metadata-ref entry 'artifact-kind #f) + artifact-kind)) + (promoted-native-build-result-metadata-ref metadata 'artifacts '()))) + +(define (promoted-native-build-result-spec result) + (let* ((metadata (promoted-native-build-result-metadata result)) + (base (promoted-native-build-result-metadata-ref metadata 'freebsd-base '())) + (source (promoted-native-build-result-metadata-ref metadata 'source '()))) + `((store-path . ,(promoted-native-build-result-store-path result)) + (metadata-file . ,(promoted-native-build-result-metadata-file result)) + (executor-kind . ,(promoted-native-build-result-metadata-ref metadata 'executor-kind #f)) + (executor-name . ,(promoted-native-build-result-metadata-ref metadata 'executor-name #f)) + (executor-version . ,(promoted-native-build-result-metadata-ref metadata 'executor-version #f)) + (run-id . ,(promoted-native-build-result-metadata-ref metadata 'run-id #f)) + (version-label . ,(promoted-native-build-result-metadata-ref base 'version-label #f)) + (release . ,(promoted-native-build-result-metadata-ref base 'release #f)) + (branch . ,(promoted-native-build-result-metadata-ref base 'branch #f)) + (source-store . ,(promoted-native-build-result-metadata-ref source 'store-path #f)) + (source-root . ,(promoted-native-build-result-metadata-ref source 'source-root #f)) + (artifact-count . ,(promoted-native-build-result-metadata-ref metadata 'artifact-count 0)) + (world-store . ,(promoted-native-build-result-metadata-ref + (promoted-native-build-result-artifact-spec metadata 'world) + 'store-path + #f)) + (kernel-store . ,(promoted-native-build-result-metadata-ref + (promoted-native-build-result-artifact-spec metadata 'kernel) + 'store-path + #f)) + (headers-store . ,(promoted-native-build-result-metadata-ref + (promoted-native-build-result-artifact-spec metadata 'headers) + 'store-path + #f)) + (bootloader-store . ,(promoted-native-build-result-metadata-ref + (promoted-native-build-result-artifact-spec metadata 'bootloader) + 'store-path + #f))))) + +(define-record-type + (make-operating-system host-name freebsd-base native-build-result kernel bootloader + base-packages development-packages build-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) + (native-build-result operating-system-native-build-result) + (kernel operating-system-kernel) + (bootloader operating-system-bootloader) + (base-packages operating-system-base-packages) + (development-packages operating-system-development-packages) + (build-packages operating-system-build-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) + (native-build-result #f) + (kernel freebsd-kernel) + (bootloader freebsd-bootloader) + (base-packages %freebsd-system-packages) + (development-packages '()) + (build-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 native-build-result kernel bootloader + base-packages development-packages build-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)) + (native-build-result (operating-system-native-build-result os)) + (base-packages (operating-system-base-packages os)) + (development-packages (operating-system-development-packages os)) + (build-packages (operating-system-build-packages 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")) + (when native-build-result + (unless (promoted-native-build-result? native-build-result) + (error "operating-system native-build-result must be a record"))) + (unless (every freebsd-package? base-packages) + (error "operating-system base-packages must be a list of records")) + (unless (every freebsd-package? development-packages) + (error "operating-system development-packages must be a list of records")) + (unless (every freebsd-package? build-packages) + (error "operating-system build-packages must be a list of records")) + (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" + "metadata/system-declaration.scm" + "metadata/system-declaration-info.scm" + "metadata/system-declaration-system" + "activate" + "shepherd/init.scm" + "share/fruix/node/scripts/fruix.scm" + "usr/local/bin/fruix") + (if (operating-system-native-build-result os) + '("metadata/promoted-native-build-result.scm") + '()) + (if (null? (operating-system-development-packages os)) + '() + '("usr/local/bin/fruix-development-environment")) + (if (null? (operating-system-build-packages os)) + '() + '("usr/local/bin/fruix-build-environment" + "usr/local/bin/fruix-self-hosted-native-build")) + (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))) + (promoted-native-build-result + . ,(and (operating-system-native-build-result os) + (promoted-native-build-result-spec + (operating-system-native-build-result 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))) + (development-package-count . ,(length (operating-system-development-packages os))) + (development-packages . ,(package-names (operating-system-development-packages os))) + (build-package-count . ,(length (operating-system-build-packages os))) + (build-packages . ,(package-names (operating-system-build-packages os))) + (installed-system-command-surface-version . "4") + (bundled-fruix-node-cli-version . "1") + (development-environment-helper-version + . ,(if (null? (operating-system-development-packages os)) #f "1")) + (build-environment-helper-version + . ,(if (null? (operating-system-build-packages os)) #f "1")) + (self-hosted-native-build-helper-version + . ,(if (null? (operating-system-build-packages os)) #f "5")) + (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..c96c41f --- /dev/null +++ b/modules/fruix/system/freebsd/render.scm @@ -0,0 +1,1328 @@ +(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) + #:use-module (rnrs io ports) + #: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 (path-parent path) + (let ((index (string-rindex path #\/))) + (cond + ((not index) ".") + ((zero? index) "/") + (else (substring path 0 index))))) + +(define (read-source-file-string path) + (call-with-input-file path get-string-all)) + +(define (bundled-fruix-node-files) + (let* ((repo-root (or (getenv "FRUIX_PROJECT_ROOT") + (let ((render-file (current-filename))) + (and render-file + (path-parent + (path-parent + (path-parent + (path-parent + (path-parent render-file))))))) + (getcwd))) + (guix-root (or (getenv "GUIX_SOURCE_DIR") + (string-append (getenv "HOME") "/repos/guix"))) + (specs `((,(string-append repo-root "/scripts/fruix.scm") + . "share/fruix/node/scripts/fruix.scm") + (,(string-append repo-root "/modules/fruix/packages/freebsd.scm") + . "share/fruix/node/modules/fruix/packages/freebsd.scm") + (,(string-append repo-root "/modules/fruix/system/freebsd.scm") + . "share/fruix/node/modules/fruix/system/freebsd.scm") + (,(string-append repo-root "/modules/fruix/system/freebsd/build.scm") + . "share/fruix/node/modules/fruix/system/freebsd/build.scm") + (,(string-append repo-root "/modules/fruix/system/freebsd/executor.scm") + . "share/fruix/node/modules/fruix/system/freebsd/executor.scm") + (,(string-append repo-root "/modules/fruix/system/freebsd/media.scm") + . "share/fruix/node/modules/fruix/system/freebsd/media.scm") + (,(string-append repo-root "/modules/fruix/system/freebsd/model.scm") + . "share/fruix/node/modules/fruix/system/freebsd/model.scm") + (,(string-append repo-root "/modules/fruix/system/freebsd/render.scm") + . "share/fruix/node/modules/fruix/system/freebsd/render.scm") + (,(string-append repo-root "/modules/fruix/system/freebsd/source.scm") + . "share/fruix/node/modules/fruix/system/freebsd/source.scm") + (,(string-append repo-root "/modules/fruix/system/freebsd/utils.scm") + . "share/fruix/node/modules/fruix/system/freebsd/utils.scm") + (,(string-append guix-root "/guix/build/utils.scm") + . "share/fruix/node/guix/guix/build/utils.scm")))) + (map (lambda (entry) + (cons (cdr entry) + (read-source-file-string (car entry)))) + specs))) + +(define (render-installed-system-fruix os guile-store guile-extra-store shepherd-store) + (string-append + "#!/bin/sh\n" + "set -eu\n" + "PATH=/sbin:/bin:/usr/sbin:/usr/bin:/usr/local/sbin:/usr/local/bin\n" + "tool_closure=$(readlink /run/current-system 2>/dev/null || true)\n" + "if [ -n \"$tool_closure\" ]; then\n" + " PATH=\"$tool_closure/profile/bin:$tool_closure/profile/sbin:$tool_closure/profile/usr/bin:$tool_closure/profile/usr/sbin:$PATH\"\n" + "fi\n" + "export PATH\n\n" + "system_root=/var/lib/fruix/system\n" + "generations_root=\"$system_root/generations\"\n" + "current_link=\"$system_root/current\"\n" + "current_generation_file=\"$system_root/current-generation\"\n" + "rollback_link=\"$system_root/rollback\"\n" + "rollback_generation_file=\"$system_root/rollback-generation\"\n" + "gcroots_root=/frx/var/fruix/gcroots\n" + "run_current_link=/run/current-system\n" + "node_root=/run/current-system/share/fruix/node\n" + "node_script=\"$node_root/scripts/fruix.scm\"\n" + "node_module_root=\"$node_root/modules\"\n" + "node_guix_root=\"$node_root/guix\"\n" + "declaration_file=/run/current-system/metadata/system-declaration.scm\n" + "declaration_info_file=/run/current-system/metadata/system-declaration-info.scm\n" + "declaration_system_file=/run/current-system/metadata/system-declaration-system\n" + "default_store_dir=/frx/store\n" + "guile_store='" guile-store "'\n" + "guile_extra_store='" guile-extra-store "'\n" + "shepherd_store='" shepherd-store "'\n" + "layout_version=2\n" + "host_name='" (operating-system-host-name os) "'\n" + "ready_marker='" (operating-system-ready-marker os) "'\n" + "init_mode='" (symbol->string (operating-system-init-mode os)) "'\n\n" + "usage()\n" + "{\n" + " cat <<'EOF'\n" + "Usage: fruix system status\n" + " fruix system build [DECLARATION [--system NAME] ...]\n" + " fruix system build-base [--jobs COUNT] [--store DIR]\n" + " fruix system deploy TARGET DECLARATION [--system NAME] ...\n" + " fruix system reconfigure [DECLARATION [--system NAME] ...]\n" + " fruix system switch /frx/store/...-fruix-system-...\n" + " fruix system rollback\n" + "EOF\n" + "}\n\n" + "die()\n" + "{\n" + " echo \"fruix: $*\" >&2\n" + " exit 1\n" + "}\n\n" + "read_link_maybe()\n" + "{\n" + " if [ -L \"$1\" ]; then\n" + " readlink \"$1\"\n" + " fi\n" + "}\n\n" + "read_file_maybe()\n" + "{\n" + " if [ -f \"$1\" ]; then\n" + " tr -d '\\n' < \"$1\"\n" + " fi\n" + "}\n\n" + "default_system_name()\n" + "{\n" + " read_file_maybe \"$declaration_system_file\"\n" + "}\n\n" + "symlink_force()\n" + "{\n" + " target=$1\n" + " link_name=$2\n" + " tmp_link=\"${link_name}.new.$$\"\n" + " mkdir -p \"$(dirname \"$link_name\")\"\n" + " if [ \"$link_name\" = \"$run_current_link\" ]; then\n" + " rm -f \"$tmp_link\"\n" + " ln -s \"$target\" \"$tmp_link\"\n" + " mv -h -f \"$tmp_link\" \"$link_name\"\n" + " else\n" + " rm -f \"$link_name\"\n" + " ln -s \"$target\" \"$link_name\"\n" + " fi\n" + "}\n\n" + "validate_closure()\n" + "{\n" + " closure=$1\n" + " [ -d \"$closure\" ] || die \"missing closure directory: $closure\"\n" + " [ -f \"$closure/activate\" ] || die \"closure is missing activate script: $closure\"\n" + " [ -f \"$closure/shepherd/init.scm\" ] || die \"closure is missing shepherd config: $closure\"\n" + " [ -f \"$closure/boot/loader.efi\" ] || die \"closure is missing loader.efi: $closure\"\n" + "}\n\n" + "ensure_default_declaration()\n" + "{\n" + " [ -f \"$declaration_file\" ] || die \"current declaration file is missing: $declaration_file\"\n" + " [ -f \"$declaration_info_file\" ] || die \"current declaration info file is missing: $declaration_info_file\"\n" + " current_system_name=$(default_system_name)\n" + " [ -n \"$current_system_name\" ] || die \"current declaration is missing a system variable name\"\n" + "}\n\n" + "run_node_cli()\n" + "{\n" + " [ -x \"$guile_store/bin/guile\" ] || die \"missing Guile runtime: $guile_store/bin/guile\"\n" + " [ -f \"$node_script\" ] || die \"missing bundled Fruix node CLI: $node_script\"\n" + " [ -d \"$node_module_root\" ] || die \"missing bundled Fruix modules: $node_module_root\"\n" + " [ -d \"$node_guix_root\" ] || die \"missing bundled Guix modules: $node_guix_root\"\n" + " guile_load_path=\"$node_module_root:$node_guix_root:$shepherd_store/share/guile/site/3.0:$guile_extra_store/share/guile/site/3.0\"\n" + " guile_system_path=\"$guile_store/share/guile/3.0:$guile_store/share/guile/site/3.0:$guile_store/share/guile/site:$guile_store/share/guile\"\n" + " guile_system_compiled_path=\"$guile_store/lib/guile/3.0/ccache:$guile_store/lib/guile/3.0/site-ccache\"\n" + " guile_load_compiled_path=\"$shepherd_store/lib/guile/3.0/site-ccache:$guile_extra_store/lib/guile/3.0/site-ccache\"\n" + " guile_system_extensions_path=\"$guile_store/lib/guile/3.0/extensions\"\n" + " guile_extensions_path=\"$guile_extra_store/lib/guile/3.0/extensions\"\n" + " ld_library_path=\"$guile_extra_store/lib:$guile_store/lib:/usr/local/lib\"\n" + " env \\\n" + " GUILE_AUTO_COMPILE=0 \\\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" + " LD_LIBRARY_PATH=\"$ld_library_path\" \\\n" + " GUILE_PREFIX=\"$guile_store\" \\\n" + " GUILE_EXTRA_PREFIX=\"$guile_extra_store\" \\\n" + " SHEPHERD_PREFIX=\"$shepherd_store\" \\\n" + " FRUIX_GUILE_STORE=\"$guile_store\" \\\n" + " FRUIX_GUILE_EXTRA_STORE=\"$guile_extra_store\" \\\n" + " FRUIX_SHEPHERD_STORE=\"$shepherd_store\" \\\n" + " GUIX_SOURCE_DIR=\"$node_guix_root\" \\\n" + " FRUIX_PROJECT_ROOT=\"$node_root\" \\\n" + " \"$guile_store/bin/guile\" --no-auto-compile -s \"$node_script\" \"$@\"\n" + "}\n\n" + "system_build()\n" + "{\n" + " if [ $# -eq 0 ]; then\n" + " ensure_default_declaration\n" + " run_node_cli system build \"$declaration_file\" --system \"$current_system_name\" --store \"$default_store_dir\"\n" + " else\n" + " run_node_cli system build \"$@\"\n" + " fi\n" + "}\n\n" + "deploy_system()\n" + "{\n" + " [ $# -ge 1 ] || die \"deploy requires TARGET and a declaration file or closure path\"\n" + " target_host=$1\n" + " shift\n" + " if [ $# -eq 0 ]; then\n" + " ensure_default_declaration\n" + " run_node_cli system deploy \"$target_host\" \"$declaration_file\" --system \"$current_system_name\" --store \"$default_store_dir\"\n" + " else\n" + " run_node_cli system deploy \"$target_host\" \"$@\"\n" + " fi\n" + "}\n\n" + "build_base_system()\n" + "{\n" + " store_dir=$default_store_dir\n" + " jobs=\"\"\n" + " while [ $# -gt 0 ]; do\n" + " case \"$1\" in\n" + " --jobs)\n" + " [ $# -ge 2 ] || die \"build-base requires a value after --jobs\"\n" + " jobs=$2\n" + " shift 2\n" + " ;;\n" + " --jobs=*)\n" + " jobs=${1#--jobs=}\n" + " shift\n" + " ;;\n" + " --store)\n" + " [ $# -ge 2 ] || die \"build-base requires a value after --store\"\n" + " store_dir=$2\n" + " shift 2\n" + " ;;\n" + " --store=*)\n" + " store_dir=${1#--store=}\n" + " shift\n" + " ;;\n" + " *)\n" + " die \"unsupported build-base argument: $1\"\n" + " ;;\n" + " esac\n" + " done\n" + " case \"$jobs\" in\n" + " '')\n" + " ;;\n" + " *[!0-9]*)\n" + " die \"build-base job count must be numeric: $jobs\"\n" + " ;;\n" + " esac\n" + " [ -x /usr/local/bin/fruix-self-hosted-native-build ] || die \"build-base helper is missing: /usr/local/bin/fruix-self-hosted-native-build\"\n" + " build_output=$(mktemp /tmp/fruix-system-build-base.XXXXXX)\n" + " promote_output=$(mktemp /tmp/fruix-system-build-base-promote.XXXXXX)\n" + " cleanup_build_base() {\n" + " rm -f \"$build_output\" \"$promote_output\"\n" + " }\n" + " if [ -n \"$jobs\" ]; then\n" + " if ! env FRUIX_SELF_HOSTED_NATIVE_BUILD_JOBS=\"$jobs\" /usr/local/bin/fruix-self-hosted-native-build > \"$build_output\"; then\n" + " cat \"$build_output\" >&2 || true\n" + " cleanup_build_base\n" + " exit 1\n" + " fi\n" + " else\n" + " if ! /usr/local/bin/fruix-self-hosted-native-build > \"$build_output\"; then\n" + " cat \"$build_output\" >&2 || true\n" + " cleanup_build_base\n" + " exit 1\n" + " fi\n" + " fi\n" + " result_root=$(sed -n 's/^result_root=//p' \"$build_output\" | tail -n 1)\n" + " [ -n \"$result_root\" ] || { cleanup_build_base; die \"failed to recover result_root from build-base output\"; }\n" + " if ! run_node_cli native-build promote \"$result_root\" --store \"$store_dir\" > \"$promote_output\"; then\n" + " cat \"$build_output\" >&2 || true\n" + " cat \"$promote_output\" >&2 || true\n" + " cleanup_build_base\n" + " exit 1\n" + " fi\n" + " result_store=$(sed -n 's/^result_store=//p' \"$promote_output\" | tail -n 1)\n" + " [ -n \"$result_store\" ] || { cleanup_build_base; die \"failed to recover result_store from promotion output\"; }\n" + " cat \"$build_output\"\n" + " cat \"$promote_output\"\n" + " printf 'build_base_result_root=%s\\n' \"$result_root\"\n" + " printf 'build_base_result_store=%s\\n' \"$result_store\"\n" + " printf 'build_base_store_dir=%s\\n' \"$store_dir\"\n" + " printf 'build_base=ok\\n'\n" + " cleanup_build_base\n" + "}\n\n" + "reconfigure_system()\n" + "{\n" + " build_output=$(mktemp /tmp/fruix-system-reconfigure.XXXXXX)\n" + " if [ $# -eq 0 ]; then\n" + " ensure_default_declaration\n" + " if ! run_node_cli system build \"$declaration_file\" --system \"$current_system_name\" --store \"$default_store_dir\" > \"$build_output\"; then\n" + " cat \"$build_output\" >&2 || true\n" + " rm -f \"$build_output\"\n" + " exit 1\n" + " fi\n" + " else\n" + " if ! run_node_cli system build \"$@\" > \"$build_output\"; then\n" + " cat \"$build_output\" >&2 || true\n" + " rm -f \"$build_output\"\n" + " exit 1\n" + " fi\n" + " fi\n" + " closure=$(sed -n 's/^closure_path=//p' \"$build_output\" | tail -n 1)\n" + " [ -n \"$closure\" ] || die \"failed to recover closure_path from in-system build output\"\n" + " cat \"$build_output\"\n" + " rm -f \"$build_output\"\n" + " switch_to_closure \"$closure\"\n" + " printf 'reconfigure_closure=%s\\n' \"$closure\"\n" + " printf 'reboot_required=true\\n'\n" + "}\n\n" + "max_generation_number()\n" + "{\n" + " max=0\n" + " if [ -d \"$generations_root\" ]; then\n" + " for path in \"$generations_root\"/*; do\n" + " [ -d \"$path\" ] || continue\n" + " base=$(basename \"$path\")\n" + " case \"$base\" in\n" + " ''|*[!0-9]*)\n" + " continue\n" + " ;;\n" + " esac\n" + " if [ \"$base\" -gt \"$max\" ]; then\n" + " max=$base\n" + " fi\n" + " done\n" + " fi\n" + " printf '%s\\n' \"$max\"\n" + "}\n\n" + "next_generation_number()\n" + "{\n" + " max=$(max_generation_number)\n" + " printf '%s\\n' $((max + 1))\n" + "}\n\n" + "write_generation_metadata()\n" + "{\n" + " generation=$1\n" + " closure=$2\n" + " action=$3\n" + " previous_generation=$4\n" + " previous_closure=$5\n" + " generation_dir=\"$generations_root/$generation\"\n" + " install_metadata_path=\"/var/lib/fruix/system/generations/$generation/install.scm\"\n" + " cat > \"$generation_dir/metadata.scm\" < \"$generation_dir/provenance.scm\" < \"$generation_dir/install.scm\" </dev/null 2>&1; then\n" + " mkdir -p \"$esp_mount/EFI/BOOT\"\n" + " cp \"$closure/boot/loader.efi\" \"$esp_mount/EFI/BOOT/BOOTX64.EFI\"\n" + " sync\n" + " /sbin/umount \"$esp_mount\" >/dev/null 2>&1 || true\n" + " fi\n" + " rmdir \"$esp_mount\" >/dev/null 2>&1 || true\n" + "}\n\n" + "status()\n" + "{\n" + " current_generation=$(read_file_maybe \"$current_generation_file\")\n" + " current_generation_link=$(read_link_maybe \"$current_link\")\n" + " current_closure=$(read_link_maybe \"$run_current_link\")\n" + " rollback_generation=$(read_file_maybe \"$rollback_generation_file\")\n" + " rollback_generation_link=$(read_link_maybe \"$rollback_link\")\n" + " rollback_closure=\"\"\n" + " if [ -n \"$rollback_generation_link\" ] && [ -L \"$system_root/$rollback_generation_link/closure\" ]; then\n" + " rollback_closure=$(readlink \"$system_root/$rollback_generation_link/closure\")\n" + " fi\n" + " printf 'current_generation=%s\\n' \"$current_generation\"\n" + " printf 'current_link=%s\\n' \"$current_generation_link\"\n" + " printf 'current_closure=%s\\n' \"$current_closure\"\n" + " printf 'rollback_generation=%s\\n' \"$rollback_generation\"\n" + " printf 'rollback_link=%s\\n' \"$rollback_generation_link\"\n" + " printf 'rollback_closure=%s\\n' \"$rollback_closure\"\n" + "}\n\n" + "switch_to_closure()\n" + "{\n" + " target_closure=$1\n" + " validate_closure \"$target_closure\"\n" + " current_generation=$(read_file_maybe \"$current_generation_file\")\n" + " current_closure=$(read_link_maybe \"$run_current_link\")\n" + " [ -n \"$current_generation\" ] || die \"missing current generation metadata\"\n" + " [ -n \"$current_closure\" ] || die \"missing /run/current-system target\"\n" + " if [ \"$target_closure\" = \"$current_closure\" ]; then\n" + " status\n" + " return 0\n" + " fi\n" + " new_generation=$(next_generation_number)\n" + " prepare_generation \"$new_generation\" \"$target_closure\" switch \"$current_generation\" \"$current_closure\"\n" + " symlink_force \"generations/$current_generation\" \"$rollback_link\"\n" + " printf '%s\\n' \"$current_generation\" > \"$rollback_generation_file\"\n" + " symlink_force \"$current_closure\" \"$gcroots_root/rollback-system\"\n" + " symlink_force \"generations/$new_generation\" \"$current_link\"\n" + " printf '%s\\n' \"$new_generation\" > \"$current_generation_file\"\n" + " symlink_force \"$target_closure\" \"$gcroots_root/system-$new_generation\"\n" + " symlink_force \"$target_closure\" \"$gcroots_root/current-system\"\n" + " symlink_force \"$target_closure\" \"$run_current_link\"\n" + " update_efi_loader \"$target_closure\"\n" + " status\n" + "}\n\n" + "rollback_current_generation()\n" + "{\n" + " rollback_generation=$(read_file_maybe \"$rollback_generation_file\")\n" + " rollback_generation_link=$(read_link_maybe \"$rollback_link\")\n" + " [ -n \"$rollback_generation\" ] || die \"no rollback generation is recorded\"\n" + " [ -n \"$rollback_generation_link\" ] || die \"no rollback link is recorded\"\n" + " rollback_closure=$(read_link_maybe \"$system_root/$rollback_generation_link/closure\")\n" + " [ -n \"$rollback_closure\" ] || die \"rollback generation has no closure link\"\n" + " current_generation=$(read_file_maybe \"$current_generation_file\")\n" + " current_closure=$(read_link_maybe \"$run_current_link\")\n" + " [ -n \"$current_generation\" ] || die \"missing current generation metadata\"\n" + " [ -n \"$current_closure\" ] || die \"missing current closure link\"\n" + " symlink_force \"generations/$current_generation\" \"$rollback_link\"\n" + " printf '%s\\n' \"$current_generation\" > \"$rollback_generation_file\"\n" + " symlink_force \"$current_closure\" \"$gcroots_root/rollback-system\"\n" + " symlink_force \"$rollback_generation_link\" \"$current_link\"\n" + " printf '%s\\n' \"$rollback_generation\" > \"$current_generation_file\"\n" + " symlink_force \"$rollback_closure\" \"$gcroots_root/current-system\"\n" + " symlink_force \"$rollback_closure\" \"$run_current_link\"\n" + " update_efi_loader \"$rollback_closure\"\n" + " status\n" + "}\n\n" + "case \"${1:-}\" in\n" + " system)\n" + " case \"${2:-}\" in\n" + " status)\n" + " [ $# -eq 2 ] || { usage >&2; exit 1; }\n" + " status\n" + " ;;\n" + " build)\n" + " shift 2\n" + " system_build \"$@\"\n" + " ;;\n" + " build-base)\n" + " shift 2\n" + " build_base_system \"$@\"\n" + " ;;\n" + " deploy)\n" + " shift 2\n" + " deploy_system \"$@\"\n" + " ;;\n" + " reconfigure)\n" + " shift 2\n" + " reconfigure_system \"$@\"\n" + " ;;\n" + " switch)\n" + " [ $# -eq 3 ] || { usage >&2; exit 1; }\n" + " switch_to_closure \"$3\"\n" + " ;;\n" + " rollback)\n" + " [ $# -eq 2 ] || { usage >&2; exit 1; }\n" + " rollback_current_generation\n" + " ;;\n" + " --help|-h|'')\n" + " usage\n" + " ;;\n" + " *)\n" + " usage >&2\n" + " exit 1\n" + " ;;\n" + " esac\n" + " ;;\n" + " --help|-h|'')\n" + " usage\n" + " ;;\n" + " *)\n" + " usage >&2\n" + " exit 1\n" + " ;;\n" + "esac\n")) +(define (render-development-environment-script os) + (string-append + "#!/bin/sh\n" + "set -eu\n" + "profile=/run/current-system/development-profile\n" + "[ -d \"$profile\" ] || {\n" + " echo \"fruix-development-environment: development profile is not available\" >&2\n" + " exit 1\n" + "}\n" + "cat <&2\n" + " exit 1\n" + "}\n" + "cat <&2\n" + " exit 1\n" + "}\n" + "[ -x /usr/local/bin/fruix-build-environment ] || {\n" + " echo \"fruix-self-hosted-native-build: build environment helper is missing\" >&2\n" + " exit 1\n" + "}\n" + "eval \"$(/usr/local/bin/fruix-build-environment)\"\n" + "[ \"${FRUIX_BUILD_PROFILE:-}\" = \"$profile\" ] || {\n" + " echo \"fruix-self-hosted-native-build: build environment helper exported an unexpected profile\" >&2\n" + " exit 1\n" + "}\n" + "[ -L /usr/include ] || {\n" + " echo \"fruix-self-hosted-native-build: /usr/include compatibility link is missing\" >&2\n" + " exit 1\n" + "}\n" + "[ \"$(readlink /usr/include)\" = \"/run/current-system/build-profile/usr/include\" ] || {\n" + " echo \"fruix-self-hosted-native-build: /usr/include points at the wrong target\" >&2\n" + " exit 1\n" + "}\n" + "[ -L /usr/share/mk ] || {\n" + " echo \"fruix-self-hosted-native-build: /usr/share/mk compatibility link is missing\" >&2\n" + " exit 1\n" + "}\n" + "[ \"$(readlink /usr/share/mk)\" = \"/run/current-system/build-profile/usr/share/mk\" ] || {\n" + " echo \"fruix-self-hosted-native-build: /usr/share/mk points at the wrong target\" >&2\n" + " exit 1\n" + "}\n" + "make_cmd=${FRUIX_BMAKE:-make}\n" + "jobs=${FRUIX_SELF_HOSTED_NATIVE_BUILD_JOBS:-$(sysctl -n hw.ncpu)}\n" + "case \"$jobs\" in\n" + " ''|*[!0-9]*)\n" + " echo \"fruix-self-hosted-native-build: invalid job count: $jobs\" >&2\n" + " exit 1\n" + " ;;\n" + "esac\n" + "run_id=${FRUIX_SELF_HOSTED_NATIVE_BUILD_ID:-$(date -u +%Y%m%dT%H%M%SZ)}\n" + "build_root_base=${FRUIX_SELF_HOSTED_NATIVE_BUILD_ROOT_BASE:-/var/tmp/fruix-self-hosted-native-builds}\n" + "result_root_base=${FRUIX_SELF_HOSTED_NATIVE_BUILD_OUTPUT_BASE:-/var/lib/fruix/native-builds}\n" + "build_root=$build_root_base/$run_id\n" + "result_root=$result_root_base/$run_id\n" + "logdir=$result_root/logs\n" + "status_file=$result_root/status\n" + "metadata_file=$result_root/metadata.txt\n" + "promotion_file=$result_root/promotion.scm\n" + "world_stage=$build_root/stage-world\n" + "kernel_stage=$build_root/stage-kernel\n" + "world_artifact=$result_root/artifacts/world\n" + "headers_artifact=$result_root/artifacts/headers\n" + "kernel_artifact=$result_root/artifacts/kernel\n" + "bootloader_artifact=$result_root/artifacts/bootloader\n" + "latest_link=$result_root_base/latest\n" + "mkdir -p \"$build_root\" \"$result_root\" \"$logdir\"\n" + "printf 'running\\n' > \"$status_file\"\n" + "fail_mark() {\n" + " rc=$?\n" + " if [ \"$rc\" -ne 0 ]; then\n" + " printf 'failed\\n' > \"$status_file\"\n" + " fi\n" + "}\n" + "trap fail_mark EXIT HUP INT TERM\n" + "closure=$(readlink /run/current-system)\n" + "store_layout=$closure/metadata/store-layout.scm\n" + "[ -f \"$store_layout\" ] || {\n" + " echo \"fruix-self-hosted-native-build: store layout metadata is missing\" >&2\n" + " exit 1\n" + "}\n" + "source_store=$(sed -n 's/.*\"\\(\\/frx\\/store\\/[^\"]*-freebsd-source-[^\"]*\\)\".*/\\1/p' \"$store_layout\" | head -n 1)\n" + "[ -n \"$source_store\" ] || {\n" + " echo \"fruix-self-hosted-native-build: failed to recover source store from store-layout.scm\" >&2\n" + " exit 1\n" + "}\n" + "source_root=$source_store/tree\n" + "[ -d \"$source_root\" ] || {\n" + " echo \"fruix-self-hosted-native-build: source root is missing: $source_root\" >&2\n" + " exit 1\n" + "}\n" + "mkdir -p \"$world_artifact\" \"$headers_artifact/usr\" \"$kernel_artifact/boot\" \"$bootloader_artifact/boot\"\n" + "export MAKEOBJDIRPREFIX=\"$build_root/obj\"\n" + "\"$make_cmd\" -j\"$jobs\" -C \"$source_root\" " build-common " buildworld > \"$logdir/buildworld.log\" 2>&1\n" + "\"$make_cmd\" -j\"$jobs\" -C \"$source_root\" " build-common " buildkernel > \"$logdir/buildkernel.log\" 2>&1\n" + "\"$make_cmd\" -C \"$source_root\" " install-common " DESTDIR=\"$world_stage\" installworld > \"$logdir/installworld.log\" 2>&1\n" + "\"$make_cmd\" -C \"$source_root\" " install-common " DESTDIR=\"$world_stage\" distribution > \"$logdir/distribution.log\" 2>&1\n" + "\"$make_cmd\" -C \"$source_root\" " install-common " DESTDIR=\"$kernel_stage\" installkernel > \"$logdir/installkernel.log\" 2>&1\n" + "cp -a \"$world_stage/.\" \"$world_artifact/\"\n" + "cp -a \"$kernel_stage/boot/kernel\" \"$kernel_artifact/boot/kernel\"\n" + "cp -a \"$world_stage/usr/include\" \"$headers_artifact/usr/include\"\n" + "mkdir -p \"$headers_artifact/usr/share\"\n" + "cp -a \"$world_stage/usr/share/mk\" \"$headers_artifact/usr/share/mk\"\n" + "cp -a \"$world_stage/boot/loader\" \"$bootloader_artifact/boot/loader\"\n" + "cp -a \"$world_stage/boot/loader.efi\" \"$bootloader_artifact/boot/loader.efi\"\n" + "cp -a \"$world_stage/boot/device.hints\" \"$bootloader_artifact/boot/device.hints\"\n" + "cp -a \"$world_stage/boot/defaults\" \"$bootloader_artifact/boot/defaults\"\n" + "cp -a \"$world_stage/boot/lua\" \"$bootloader_artifact/boot/lua\"\n" + "[ -f \"$world_artifact/bin/sh\" ]\n" + "[ -f \"$kernel_artifact/boot/kernel/kernel\" ]\n" + "[ -f \"$headers_artifact/usr/include/sys/param.h\" ]\n" + "[ -f \"$headers_artifact/usr/share/mk/bsd.prog.mk\" ]\n" + "[ -f \"$bootloader_artifact/boot/loader.efi\" ]\n" + "[ -f \"$bootloader_artifact/boot/defaults/loader.conf\" ]\n" + "[ -f \"$bootloader_artifact/boot/lua/loader.lua\" ]\n" + "sha_kernel=$(sha256 -q \"$kernel_artifact/boot/kernel/kernel\")\n" + "sha_loader=$(sha256 -q \"$bootloader_artifact/boot/loader.efi\")\n" + "sha_param=$(sha256 -q \"$headers_artifact/usr/include/sys/param.h\")\n" + "buildworld_tail=$(tail -n 20 \"$logdir/buildworld.log\" | tr '\\n' ' ')\n" + "buildkernel_tail=$(tail -n 20 \"$logdir/buildkernel.log\" | tr '\\n' ' ')\n" + "installworld_tail=$(tail -n 20 \"$logdir/installworld.log\" | tr '\\n' ' ')\n" + "distribution_tail=$(tail -n 20 \"$logdir/distribution.log\" | tr '\\n' ' ')\n" + "installkernel_tail=$(tail -n 20 \"$logdir/installkernel.log\" | tr '\\n' ' ')\n" + "root_df=$(df -h / | tail -n 1 | tr -s ' ' | tr '\\t' ' ')\n" + "build_root_size=$(du -sh \"$build_root\" | awk '{print $1}')\n" + "result_root_size=$(du -sh \"$result_root\" | awk '{print $1}')\n" + "world_artifact_size=$(du -sh \"$world_artifact\" | awk '{print $1}')\n" + "kernel_artifact_size=$(du -sh \"$kernel_artifact\" | awk '{print $1}')\n" + "headers_artifact_size=$(du -sh \"$headers_artifact\" | awk '{print $1}')\n" + "bootloader_artifact_size=$(du -sh \"$bootloader_artifact\" | awk '{print $1}')\n" + "rm -f \"$latest_link\"\n" + "ln -s \"$result_root\" \"$latest_link\"\n" + "cat >\"$promotion_file\" <\"$metadata_file\" < \"$status_file\"\n" + "cat \"$metadata_file\"\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)) + ("usr/local/bin/fruix" + . ,(render-installed-system-fruix os guile-store guile-extra-store shepherd-store))) + (bundled-fruix-node-files) + (if (null? (operating-system-development-packages os)) + '() + `(("usr/local/bin/fruix-development-environment" + . ,(render-development-environment-script os)))) + (if (null? (operating-system-build-packages os)) + '() + `(("usr/local/bin/fruix-build-environment" + . ,(render-build-environment-script os)) + ("usr/local/bin/fruix-self-hosted-native-build" + . ,(render-self-hosted-native-build-script 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..ef6b36e --- /dev/null +++ b/modules/fruix/system/freebsd/source.scm @@ -0,0 +1,204 @@ +(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/" + (sha256-string (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/" + (sha256-string (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)) + (display-name (string-append "freebsd-source-" + (safe-name-fragment (freebsd-source-name source)))) + (output-path (make-store-path store-dir display-name manifest + #:kind 'freebsd-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..31c0613 --- /dev/null +++ b/modules/fruix/system/freebsd/utils.scm @@ -0,0 +1,311 @@ +(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 + sha256-string + store-hash-string + make-store-path + file-hash + directory-entries + path-signature + tree-content-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 (sha256-string text) + (let ((tmp (command-output "mktemp" + (string-append (getenv* "TMPDIR" "/tmp") + "/fruix-system-hash.XXXXXX")))) + (dynamic-wind + (lambda () #t) + (lambda () + (write-file tmp text) + (command-output "sha256" "-q" tmp)) + (lambda () + (delete-file-if-exists tmp))))) + +(define store-hash-visible-length 40) +(define store-hash-scheme-version "1") + +(define (store-identity-field value) + (cond ((symbol? value) + (symbol->string value)) + ((string? value) + value) + (else + (object->string value)))) + +(define* (store-hash-string payload #:key (kind 'item) name (output "out")) + (let* ((identity `((scheme . "fruix-store-path") + (version . ,store-hash-scheme-version) + (kind . ,(store-identity-field kind)) + (name . ,(store-identity-field (or name ""))) + (output . ,(store-identity-field output)) + (payload . ,payload))) + (digest (sha256-string (object->string identity)))) + (string-take digest store-hash-visible-length))) + +(define* (make-store-path store-dir display-name payload + #:key + (kind 'item) + name + (output "out")) + (string-append store-dir "/" + (store-hash-string payload + #:kind kind + #:name (or name display-name) + #:output output) + "-" + display-name)) + +(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 (tree-content-signature root) + (define (walk path relative) + (let ((st (lstat path))) + (case (stat:type st) + ((regular) + (string-append "file:" relative ":" (file-hash path))) + ((symlink) + (string-append "symlink:" relative ":" (readlink path))) + ((directory) + (string-join + (cons (string-append "directory:" relative) + (apply append + (map (lambda (entry) + (let ((child-relative (if (string=? relative ".") + entry + (string-append relative "/" entry)))) + (list (walk (string-append path "/" entry) + child-relative)))) + (directory-entries path)))) + "\n")) + (else + (string-append "other:" relative ":" (symbol->string (stat:type st))))))) + (walk root ".")) + +(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)))) + (sha256-string (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)) + diff --git a/scripts/fruix.scm b/scripts/fruix.scm new file mode 100644 index 0000000..502eeb9 --- /dev/null +++ b/scripts/fruix.scm @@ -0,0 +1,1072 @@ +#!/tmp/guile-freebsd-validate-install/bin/guile -s +!# + +(use-modules (fruix system freebsd) + (fruix system freebsd utils) + (fruix packages freebsd) + (ice-9 format) + (ice-9 match) + (srfi srfi-1) + (srfi srfi-13) + (rnrs io ports)) + +(define (usage code) + (format (if (= code 0) #t (current-error-port)) + "Usage: fruix COMMAND ...\n\ +\n\ +Commands:\n\ + system ACTION ... Build or materialize Fruix system artifacts.\n\ + source ACTION ... Fetch or snapshot declarative FreeBSD source inputs.\n\ + native-build ACTION ... Promote native build results into Fruix store objects.\n\ +\n\ +System actions:\n\ + build Materialize the Fruix system closure in /frx/store.\n\ + deploy Build or transfer a Fruix system closure onto a remote Fruix node over SSH.\n\ + image Materialize the Fruix disk image in /frx/store.\n\ + installer Materialize a bootable Fruix installer image in /frx/store.\n\ + installer-iso Materialize a bootable Fruix installer ISO in /frx/store.\n\ + install Install the Fruix system onto --target PATH.\n\ + rootfs Materialize a rootfs tree at --rootfs DIR or ROOTFS-DIR.\n\ +\n\ +System options:\n\ + --system NAME Scheme variable holding the operating-system object.\n\ + --store DIR Store directory to use (default: /frx/store).\n\ + --disk-capacity SIZE Disk capacity for 'image', 'installer', or raw-file 'install' targets.\n\ + --root-size SIZE Root filesystem size for 'image', 'installer', 'installer-iso', or 'install' (example: 6g).\n\ + --target PATH Install target for 'install' (raw image file or /dev/... device).\n\ + --install-target-device DEVICE\n\ + Target block device used by the booted 'installer' environment.\n\ + --rootfs DIR Rootfs target for 'rootfs'.\n\ + --host HOST Remote host for 'deploy' (or use TARGET as first positional argument).\n\ + --user USER Remote SSH user for 'deploy' (default: root).\n\ + --port PORT Remote SSH port for 'deploy' (default: 22).\n\ + --identity FILE SSH identity file for 'deploy'.\n\ + --reboot Reboot the remote node after 'deploy'.\n\ +\n\ +Source actions:\n\ + materialize Materialize a declared FreeBSD source tree in /frx/store.\n\ +\n\ +Native-build actions:\n\ + promote Promote a native build result root into /frx/store.\n\ +\n\ +Native-build options:\n\ + --store DIR Store directory to use (default: /frx/store).\n\ +\n\ +Source options:\n\ + --source NAME Scheme variable holding the freebsd-source object.\n\ + --store DIR Store directory to use (default: /frx/store).\n\ + --cache DIR Cache directory to use (default: /frx/var/cache/fruix/freebsd-source).\n\ +\n\ +Common options:\n\ + --help Show this help.\n") + (exit code)) + +(define (option-value arg prefix) + (and (string-prefix? prefix arg) + (substring arg (string-length prefix)))) + +(define (stringify value) + (cond ((string? value) value) + ((symbol? value) (symbol->string value)) + ((number? value) (number->string value)) + ((boolean? value) (if value "true" "false")) + (else (call-with-output-string (lambda (port) (write value port)))))) + +(define (emit-metadata fields) + (for-each (lambda (field) + (format #t "~a=~a~%" (car field) (stringify (cdr field)))) + fields)) + +(define (read-file-string file) + (call-with-input-file file get-string-all)) + +(define (lookup-bound-value module symbol) + (let ((var (module-variable module symbol))) + (and var (variable-ref var)))) + +(define candidate-operating-system-symbols + '(operating-system + phase16-operating-system + phase15-operating-system + phase10-operating-system + phase9-operating-system + phase8-operating-system + phase7-operating-system + default-operating-system + os)) + +(define candidate-freebsd-source-symbols + '(phase16-source + declared-source + source + src)) + +(define (resolve-operating-system-symbol module requested) + (or requested + (find (lambda (symbol) + (let ((value (lookup-bound-value module symbol))) + (and value (operating-system? value)))) + candidate-operating-system-symbols) + (error "could not infer operating-system variable; use --system NAME"))) + +(define (resolve-freebsd-source-symbol module requested) + (or requested + (find (lambda (symbol) + (let ((value (lookup-bound-value module symbol))) + (and value (freebsd-source? value)))) + candidate-freebsd-source-symbols) + (error "could not infer freebsd-source variable; use --source NAME"))) + +(define (load-operating-system-from-file file requested-symbol) + (unless (file-exists? file) + (error "operating-system file does not exist" file)) + (primitive-load file) + (let* ((module (current-module)) + (symbol (resolve-operating-system-symbol module requested-symbol)) + (value (lookup-bound-value module symbol))) + (unless (and value (operating-system? value)) + (error "resolved variable is not an operating-system" symbol)) + (validate-operating-system value) + (values value symbol))) + +(define (load-freebsd-source-from-file file requested-symbol) + (unless (file-exists? file) + (error "freebsd-source file does not exist" file)) + (primitive-load file) + (let* ((module (current-module)) + (symbol (resolve-freebsd-source-symbol module requested-symbol)) + (value (lookup-bound-value module symbol))) + (unless (and value (freebsd-source? value)) + (error "resolved variable is not a freebsd-source" symbol)) + (values value symbol))) + +(define (parse-system-arguments action rest) + (let loop ((args rest) + (positional '()) + (system-name #f) + (store-dir "/frx/store") + (disk-capacity #f) + (root-size #f) + (target #f) + (install-target-device #f) + (rootfs #f) + (deploy-host #f) + (deploy-user "root") + (deploy-port "22") + (identity-file #f) + (reboot? #f)) + (match args + (() + (let ((positional (reverse positional))) + `((command . "system") + (action . ,action) + (positional . ,positional) + (system-name . ,system-name) + (store-dir . ,store-dir) + (disk-capacity . ,disk-capacity) + (root-size . ,root-size) + (target . ,target) + (install-target-device . ,install-target-device) + (rootfs . ,rootfs) + (deploy-host . ,deploy-host) + (deploy-user . ,deploy-user) + (deploy-port . ,deploy-port) + (identity-file . ,identity-file) + (reboot? . ,reboot?)))) + (("--help") + (usage 0)) + (((? (lambda (arg) (string-prefix? "--system=" arg)) arg) . tail) + (loop tail positional (option-value arg "--system=") store-dir disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot?)) + (("--system" value . tail) + (loop tail positional value store-dir disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot?)) + (((? (lambda (arg) (string-prefix? "--store=" arg)) arg) . tail) + (loop tail positional system-name (option-value arg "--store=") disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot?)) + (("--store" value . tail) + (loop tail positional system-name value disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot?)) + (((? (lambda (arg) (string-prefix? "--disk-capacity=" arg)) arg) . tail) + (loop tail positional system-name store-dir (option-value arg "--disk-capacity=") root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot?)) + (("--disk-capacity" value . tail) + (loop tail positional system-name store-dir value root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot?)) + (((? (lambda (arg) (string-prefix? "--root-size=" arg)) arg) . tail) + (loop tail positional system-name store-dir disk-capacity (option-value arg "--root-size=") target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot?)) + (("--root-size" value . tail) + (loop tail positional system-name store-dir disk-capacity value target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot?)) + (((? (lambda (arg) (string-prefix? "--target=" arg)) arg) . tail) + (loop tail positional system-name store-dir disk-capacity root-size (option-value arg "--target=") install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot?)) + (("--target" value . tail) + (loop tail positional system-name store-dir disk-capacity root-size value install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot?)) + (((? (lambda (arg) (string-prefix? "--install-target-device=" arg)) arg) . tail) + (loop tail positional system-name store-dir disk-capacity root-size target + (option-value arg "--install-target-device=") rootfs deploy-host deploy-user deploy-port identity-file reboot?)) + (("--install-target-device" value . tail) + (loop tail positional system-name store-dir disk-capacity root-size target value rootfs deploy-host deploy-user deploy-port identity-file reboot?)) + (((? (lambda (arg) (string-prefix? "--rootfs=" arg)) arg) . tail) + (loop tail positional system-name store-dir disk-capacity root-size target install-target-device + (option-value arg "--rootfs=") deploy-host deploy-user deploy-port identity-file reboot?)) + (("--rootfs" value . tail) + (loop tail positional system-name store-dir disk-capacity root-size target install-target-device value deploy-host deploy-user deploy-port identity-file reboot?)) + (((? (lambda (arg) (string-prefix? "--host=" arg)) arg) . tail) + (loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs + (option-value arg "--host=") deploy-user deploy-port identity-file reboot?)) + (("--host" value . tail) + (loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs value deploy-user deploy-port identity-file reboot?)) + (((? (lambda (arg) (string-prefix? "--user=" arg)) arg) . tail) + (loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs + deploy-host (option-value arg "--user=") deploy-port identity-file reboot?)) + (("--user" value . tail) + (loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs deploy-host value deploy-port identity-file reboot?)) + (((? (lambda (arg) (string-prefix? "--port=" arg)) arg) . tail) + (loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs + deploy-host deploy-user (option-value arg "--port=") identity-file reboot?)) + (("--port" value . tail) + (loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs deploy-host deploy-user value identity-file reboot?)) + (((? (lambda (arg) (string-prefix? "--identity=" arg)) arg) . tail) + (loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs + deploy-host deploy-user deploy-port (option-value arg "--identity=") reboot?)) + (("--identity" value . tail) + (loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port value reboot?)) + (("--reboot" . tail) + (loop tail positional system-name store-dir disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file #t)) + (((? (lambda (arg) (string-prefix? "--" arg)) arg) . _) + (error "unknown option" arg)) + ((arg . tail) + (loop tail (cons arg positional) system-name store-dir disk-capacity root-size target install-target-device rootfs deploy-host deploy-user deploy-port identity-file reboot?))))) + +(define (parse-source-arguments action rest) + (let loop ((args rest) + (positional '()) + (source-name #f) + (store-dir "/frx/store") + (cache-dir "/frx/var/cache/fruix/freebsd-source")) + (match args + (() + (let ((positional (reverse positional))) + `((command . "source") + (action . ,action) + (positional . ,positional) + (source-name . ,source-name) + (store-dir . ,store-dir) + (cache-dir . ,cache-dir)))) + (("--help") + (usage 0)) + (((? (lambda (arg) (string-prefix? "--source=" arg)) arg) . tail) + (loop tail positional (option-value arg "--source=") store-dir cache-dir)) + (("--source" value . tail) + (loop tail positional value store-dir cache-dir)) + (((? (lambda (arg) (string-prefix? "--store=" arg)) arg) . tail) + (loop tail positional source-name (option-value arg "--store=") cache-dir)) + (("--store" value . tail) + (loop tail positional source-name value cache-dir)) + (((? (lambda (arg) (string-prefix? "--cache=" arg)) arg) . tail) + (loop tail positional source-name store-dir (option-value arg "--cache="))) + (("--cache" value . tail) + (loop tail positional source-name store-dir value)) + (((? (lambda (arg) (string-prefix? "--" arg)) arg) . _) + (error "unknown option" arg)) + ((arg . tail) + (loop tail (cons arg positional) source-name store-dir cache-dir))))) + +(define (parse-native-build-arguments action rest) + (let loop ((args rest) + (positional '()) + (store-dir "/frx/store")) + (match args + (() + (let ((positional (reverse positional))) + `((command . "native-build") + (action . ,action) + (positional . ,positional) + (store-dir . ,store-dir)))) + (("--help") + (usage 0)) + (((? (lambda (arg) (string-prefix? "--store=" arg)) arg) . tail) + (loop tail positional (option-value arg "--store="))) + (("--store" value . tail) + (loop tail positional value)) + (((? (lambda (arg) (string-prefix? "--" arg)) arg) . _) + (error "unknown option" arg)) + ((arg . tail) + (loop tail (cons arg positional) store-dir))))) + +(define (parse-arguments argv) + (match argv + ((_) + (usage 1)) + ((_ "--help") + (usage 0)) + ((_ "help") + (usage 0)) + ((_ "system" "--help") + (usage 0)) + ((_ "source" "--help") + (usage 0)) + ((_ "native-build" "--help") + (usage 0)) + ((_ "system" action . rest) + (parse-system-arguments action rest)) + ((_ "source" action . rest) + (parse-source-arguments action rest)) + ((_ "native-build" action . rest) + (parse-native-build-arguments action rest)) + ((_ . _) + (usage 1)))) + +(define (emit-system-build-metadata os-file resolved-symbol store-dir os result) + (let* ((closure-path (assoc-ref result 'closure-path)) + (generated-files (assoc-ref result 'generated-files)) + (references (assoc-ref result 'references)) + (base-package-stores (assoc-ref result 'base-package-stores)) + (host-base-stores (assoc-ref result 'host-base-stores)) + (native-base-stores (assoc-ref result 'native-base-stores)) + (fruix-runtime-stores (assoc-ref result 'fruix-runtime-stores)) + (base (operating-system-freebsd-base os)) + (source (freebsd-base-source base)) + (host-provenance (call-with-input-file (assoc-ref result 'host-base-provenance-file) read))) + (emit-metadata + `((action . "build") + (os_file . ,os-file) + (system_variable . ,resolved-symbol) + (store_dir . ,store-dir) + (closure_path . ,closure-path) + (freebsd_base_name . ,(freebsd-base-name base)) + (freebsd_base_version_label . ,(freebsd-base-version-label base)) + (freebsd_base_release . ,(freebsd-base-release base)) + (freebsd_base_branch . ,(freebsd-base-branch base)) + (freebsd_base_source_root . ,(freebsd-base-source-root base)) + (freebsd_base_target . ,(freebsd-base-target base)) + (freebsd_base_target_arch . ,(freebsd-base-target-arch base)) + (freebsd_base_kernconf . ,(freebsd-base-kernconf base)) + (freebsd_base_file . ,(assoc-ref result 'freebsd-base-file)) + (freebsd_source_name . ,(freebsd-source-name source)) + (freebsd_source_kind . ,(freebsd-source-kind source)) + (freebsd_source_url . ,(or (freebsd-source-url source) "")) + (freebsd_source_path . ,(or (freebsd-source-path source) "")) + (freebsd_source_ref . ,(or (freebsd-source-ref source) "")) + (freebsd_source_commit . ,(or (freebsd-source-commit source) "")) + (freebsd_source_sha256 . ,(or (freebsd-source-sha256 source) "")) + (freebsd_source_file . ,(assoc-ref result 'freebsd-source-file)) + (freebsd_source_materializations_file . ,(assoc-ref result 'freebsd-source-materializations-file)) + (materialized_source_store_count . ,(length (assoc-ref result 'materialized-source-stores))) + (materialized_source_stores . ,(string-join (assoc-ref result 'materialized-source-stores) ",")) + (ready_marker . ,(operating-system-ready-marker os)) + (kernel_store . ,(assoc-ref result 'kernel-store)) + (bootloader_store . ,(assoc-ref result 'bootloader-store)) + (guile_store . ,(assoc-ref result 'guile-store)) + (guile_extra_store . ,(assoc-ref result 'guile-extra-store)) + (shepherd_store . ,(assoc-ref result 'shepherd-store)) + (base_package_store_count . ,(length base-package-stores)) + (base_package_stores . ,(string-join base-package-stores ",")) + (host_base_store_count . ,(length host-base-stores)) + (host_base_stores . ,(string-join host-base-stores ",")) + (native_base_store_count . ,(length native-base-stores)) + (native_base_stores . ,(string-join native-base-stores ",")) + (fruix_runtime_store_count . ,(length fruix-runtime-stores)) + (fruix_runtime_stores . ,(string-join fruix-runtime-stores ",")) + (host_base_provenance_file . ,(assoc-ref result 'host-base-provenance-file)) + (store_layout_file . ,(assoc-ref result 'store-layout-file)) + (host_freebsd_version . ,(assoc-ref host-provenance 'freebsd-version-kru)) + (host_uname . ,(assoc-ref host-provenance 'uname)) + (usr_src_git_revision . ,(assoc-ref host-provenance 'usr-src-git-revision)) + (usr_src_git_branch . ,(assoc-ref host-provenance 'usr-src-git-branch)) + (usr_src_newvers_sha256 . ,(assoc-ref host-provenance 'usr-src-newvers-sha256)) + (generated_file_count . ,(length generated-files)) + (reference_count . ,(length references)))))) + +(define (emit-system-install-metadata os-file resolved-symbol store-dir os result) + (let* ((install-spec (assoc-ref result 'install-spec)) + (store-items (assoc-ref result 'store-items)) + (host-base-stores (assoc-ref result 'host-base-stores)) + (native-base-stores (assoc-ref result 'native-base-stores)) + (fruix-runtime-stores (assoc-ref result 'fruix-runtime-stores)) + (base (operating-system-freebsd-base os)) + (source (freebsd-base-source base)) + (host-provenance (call-with-input-file (assoc-ref result 'host-base-provenance-file) read))) + (emit-metadata + `((action . "install") + (os_file . ,os-file) + (system_variable . ,resolved-symbol) + (store_dir . ,store-dir) + (target . ,(assoc-ref result 'target)) + (target_kind . ,(assoc-ref result 'target-kind)) + (target_device . ,(assoc-ref result 'target-device)) + (esp_device . ,(assoc-ref result 'esp-device)) + (root_device . ,(assoc-ref result 'root-device)) + (install_metadata_path . ,(assoc-ref result 'install-metadata-path)) + (freebsd_base_name . ,(freebsd-base-name base)) + (freebsd_base_version_label . ,(freebsd-base-version-label base)) + (freebsd_base_release . ,(freebsd-base-release base)) + (freebsd_base_branch . ,(freebsd-base-branch base)) + (freebsd_base_source_root . ,(freebsd-base-source-root base)) + (freebsd_base_target . ,(freebsd-base-target base)) + (freebsd_base_target_arch . ,(freebsd-base-target-arch base)) + (freebsd_base_kernconf . ,(freebsd-base-kernconf base)) + (freebsd_base_file . ,(assoc-ref result 'freebsd-base-file)) + (freebsd_source_name . ,(freebsd-source-name source)) + (freebsd_source_kind . ,(freebsd-source-kind source)) + (freebsd_source_url . ,(or (freebsd-source-url source) "")) + (freebsd_source_path . ,(or (freebsd-source-path source) "")) + (freebsd_source_ref . ,(or (freebsd-source-ref source) "")) + (freebsd_source_commit . ,(or (freebsd-source-commit source) "")) + (freebsd_source_sha256 . ,(or (freebsd-source-sha256 source) "")) + (freebsd_source_file . ,(assoc-ref result 'freebsd-source-file)) + (freebsd_source_materializations_file . ,(assoc-ref result 'freebsd-source-materializations-file)) + (materialized_source_store_count . ,(length (assoc-ref result 'materialized-source-stores))) + (materialized_source_stores . ,(string-join (assoc-ref result 'materialized-source-stores) ",")) + (disk_capacity . ,(assoc-ref install-spec 'disk-capacity)) + (root_size . ,(assoc-ref install-spec 'root-size)) + (efi_size . ,(assoc-ref install-spec 'efi-size)) + (closure_path . ,(assoc-ref result 'closure-path)) + (host_base_store_count . ,(length host-base-stores)) + (host_base_stores . ,(string-join host-base-stores ",")) + (native_base_store_count . ,(length native-base-stores)) + (native_base_stores . ,(string-join native-base-stores ",")) + (fruix_runtime_store_count . ,(length fruix-runtime-stores)) + (fruix_runtime_stores . ,(string-join fruix-runtime-stores ",")) + (host_base_provenance_file . ,(assoc-ref result 'host-base-provenance-file)) + (store_layout_file . ,(assoc-ref result 'store-layout-file)) + (host_freebsd_version . ,(assoc-ref host-provenance 'freebsd-version-kru)) + (host_uname . ,(assoc-ref host-provenance 'uname)) + (usr_src_git_revision . ,(assoc-ref host-provenance 'usr-src-git-revision)) + (usr_src_git_branch . ,(assoc-ref host-provenance 'usr-src-git-branch)) + (usr_src_newvers_sha256 . ,(assoc-ref host-provenance 'usr-src-newvers-sha256)) + (store_item_count . ,(length store-items)))))) + +(define (emit-system-image-metadata os-file resolved-symbol store-dir os result) + (let* ((image-spec (assoc-ref result 'image-spec)) + (store-items (assoc-ref result 'store-items)) + (host-base-stores (assoc-ref result 'host-base-stores)) + (native-base-stores (assoc-ref result 'native-base-stores)) + (fruix-runtime-stores (assoc-ref result 'fruix-runtime-stores)) + (base (operating-system-freebsd-base os)) + (source (freebsd-base-source base)) + (host-provenance (call-with-input-file (assoc-ref result 'host-base-provenance-file) read))) + (emit-metadata + `((action . "image") + (os_file . ,os-file) + (system_variable . ,resolved-symbol) + (store_dir . ,store-dir) + (freebsd_base_name . ,(freebsd-base-name base)) + (freebsd_base_version_label . ,(freebsd-base-version-label base)) + (freebsd_base_release . ,(freebsd-base-release base)) + (freebsd_base_branch . ,(freebsd-base-branch base)) + (freebsd_base_source_root . ,(freebsd-base-source-root base)) + (freebsd_base_target . ,(freebsd-base-target base)) + (freebsd_base_target_arch . ,(freebsd-base-target-arch base)) + (freebsd_base_kernconf . ,(freebsd-base-kernconf base)) + (freebsd_base_file . ,(assoc-ref result 'freebsd-base-file)) + (freebsd_source_name . ,(freebsd-source-name source)) + (freebsd_source_kind . ,(freebsd-source-kind source)) + (freebsd_source_url . ,(or (freebsd-source-url source) "")) + (freebsd_source_path . ,(or (freebsd-source-path source) "")) + (freebsd_source_ref . ,(or (freebsd-source-ref source) "")) + (freebsd_source_commit . ,(or (freebsd-source-commit source) "")) + (freebsd_source_sha256 . ,(or (freebsd-source-sha256 source) "")) + (freebsd_source_file . ,(assoc-ref result 'freebsd-source-file)) + (freebsd_source_materializations_file . ,(assoc-ref result 'freebsd-source-materializations-file)) + (materialized_source_store_count . ,(length (assoc-ref result 'materialized-source-stores))) + (materialized_source_stores . ,(string-join (assoc-ref result 'materialized-source-stores) ",")) + (disk_capacity . ,(assoc-ref image-spec 'disk-capacity)) + (root_size . ,(assoc-ref image-spec 'root-size)) + (image_store_path . ,(assoc-ref result 'image-store-path)) + (disk_image . ,(assoc-ref result 'disk-image)) + (esp_image . ,(assoc-ref result 'esp-image)) + (root_image . ,(assoc-ref result 'root-image)) + (closure_path . ,(assoc-ref result 'closure-path)) + (host_base_store_count . ,(length host-base-stores)) + (host_base_stores . ,(string-join host-base-stores ",")) + (native_base_store_count . ,(length native-base-stores)) + (native_base_stores . ,(string-join native-base-stores ",")) + (fruix_runtime_store_count . ,(length fruix-runtime-stores)) + (fruix_runtime_stores . ,(string-join fruix-runtime-stores ",")) + (host_base_provenance_file . ,(assoc-ref result 'host-base-provenance-file)) + (store_layout_file . ,(assoc-ref result 'store-layout-file)) + (host_freebsd_version . ,(assoc-ref host-provenance 'freebsd-version-kru)) + (host_uname . ,(assoc-ref host-provenance 'uname)) + (usr_src_git_revision . ,(assoc-ref host-provenance 'usr-src-git-revision)) + (usr_src_git_branch . ,(assoc-ref host-provenance 'usr-src-git-branch)) + (usr_src_newvers_sha256 . ,(assoc-ref host-provenance 'usr-src-newvers-sha256)) + (store_item_count . ,(length store-items)))))) + +(define (emit-system-installer-metadata os-file resolved-symbol store-dir os result) + (let* ((installer-image-spec (assoc-ref result 'installer-image-spec)) + (image-spec (assoc-ref result 'image-spec)) + (store-items (assoc-ref result 'store-items)) + (target-store-items (assoc-ref result 'target-store-items)) + (installer-store-items (assoc-ref result 'installer-store-items)) + (host-base-stores (assoc-ref result 'host-base-stores)) + (native-base-stores (assoc-ref result 'native-base-stores)) + (fruix-runtime-stores (assoc-ref result 'fruix-runtime-stores)) + (base (operating-system-freebsd-base os)) + (source (freebsd-base-source base)) + (host-provenance (call-with-input-file (assoc-ref result 'host-base-provenance-file) read))) + (emit-metadata + `((action . "installer") + (os_file . ,os-file) + (system_variable . ,resolved-symbol) + (store_dir . ,store-dir) + (freebsd_base_name . ,(freebsd-base-name base)) + (freebsd_base_version_label . ,(freebsd-base-version-label base)) + (freebsd_base_release . ,(freebsd-base-release base)) + (freebsd_base_branch . ,(freebsd-base-branch base)) + (freebsd_base_source_root . ,(freebsd-base-source-root base)) + (freebsd_base_target . ,(freebsd-base-target base)) + (freebsd_base_target_arch . ,(freebsd-base-target-arch base)) + (freebsd_base_kernconf . ,(freebsd-base-kernconf base)) + (freebsd_base_file . ,(assoc-ref result 'freebsd-base-file)) + (freebsd_source_name . ,(freebsd-source-name source)) + (freebsd_source_kind . ,(freebsd-source-kind source)) + (freebsd_source_url . ,(or (freebsd-source-url source) "")) + (freebsd_source_path . ,(or (freebsd-source-path source) "")) + (freebsd_source_ref . ,(or (freebsd-source-ref source) "")) + (freebsd_source_commit . ,(or (freebsd-source-commit source) "")) + (freebsd_source_sha256 . ,(or (freebsd-source-sha256 source) "")) + (freebsd_source_file . ,(assoc-ref result 'freebsd-source-file)) + (freebsd_source_materializations_file . ,(assoc-ref result 'freebsd-source-materializations-file)) + (materialized_source_store_count . ,(length (assoc-ref result 'materialized-source-stores))) + (materialized_source_stores . ,(string-join (assoc-ref result 'materialized-source-stores) ",")) + (disk_capacity . ,(assoc-ref image-spec 'disk-capacity)) + (root_size . ,(assoc-ref image-spec 'root-size)) + (installer_host_name . ,(assoc-ref installer-image-spec 'installer-host-name)) + (install_target_device . ,(assoc-ref result 'install-target-device)) + (installer_state_path . ,(assoc-ref result 'installer-state-path)) + (installer_log_path . ,(assoc-ref result 'installer-log-path)) + (image_store_path . ,(assoc-ref result 'image-store-path)) + (disk_image . ,(assoc-ref result 'disk-image)) + (esp_image . ,(assoc-ref result 'esp-image)) + (root_image . ,(assoc-ref result 'root-image)) + (installer_closure_path . ,(assoc-ref result 'installer-closure-path)) + (target_closure_path . ,(assoc-ref result 'target-closure-path)) + (host_base_store_count . ,(length host-base-stores)) + (host_base_stores . ,(string-join host-base-stores ",")) + (native_base_store_count . ,(length native-base-stores)) + (native_base_stores . ,(string-join native-base-stores ",")) + (fruix_runtime_store_count . ,(length fruix-runtime-stores)) + (fruix_runtime_stores . ,(string-join fruix-runtime-stores ",")) + (host_base_provenance_file . ,(assoc-ref result 'host-base-provenance-file)) + (store_layout_file . ,(assoc-ref result 'store-layout-file)) + (host_freebsd_version . ,(assoc-ref host-provenance 'freebsd-version-kru)) + (host_uname . ,(assoc-ref host-provenance 'uname)) + (usr_src_git_revision . ,(assoc-ref host-provenance 'usr-src-git-revision)) + (usr_src_git_branch . ,(assoc-ref host-provenance 'usr-src-git-branch)) + (usr_src_newvers_sha256 . ,(assoc-ref host-provenance 'usr-src-newvers-sha256)) + (store_item_count . ,(length store-items)) + (target_store_item_count . ,(length target-store-items)) + (installer_store_item_count . ,(length installer-store-items)))))) + +(define (emit-system-installer-iso-metadata os-file resolved-symbol store-dir os result) + (let* ((installer-iso-spec (assoc-ref result 'installer-iso-spec)) + (store-items (assoc-ref result 'store-items)) + (target-store-items (assoc-ref result 'target-store-items)) + (installer-store-items (assoc-ref result 'installer-store-items)) + (host-base-stores (assoc-ref result 'host-base-stores)) + (native-base-stores (assoc-ref result 'native-base-stores)) + (fruix-runtime-stores (assoc-ref result 'fruix-runtime-stores)) + (base (operating-system-freebsd-base os)) + (source (freebsd-base-source base)) + (host-provenance (call-with-input-file (assoc-ref result 'host-base-provenance-file) read))) + (emit-metadata + `((action . "installer-iso") + (os_file . ,os-file) + (system_variable . ,resolved-symbol) + (store_dir . ,store-dir) + (freebsd_base_name . ,(freebsd-base-name base)) + (freebsd_base_version_label . ,(freebsd-base-version-label base)) + (freebsd_base_release . ,(freebsd-base-release base)) + (freebsd_base_branch . ,(freebsd-base-branch base)) + (freebsd_base_source_root . ,(freebsd-base-source-root base)) + (freebsd_base_target . ,(freebsd-base-target base)) + (freebsd_base_target_arch . ,(freebsd-base-target-arch base)) + (freebsd_base_kernconf . ,(freebsd-base-kernconf base)) + (freebsd_base_file . ,(assoc-ref result 'freebsd-base-file)) + (freebsd_source_name . ,(freebsd-source-name source)) + (freebsd_source_kind . ,(freebsd-source-kind source)) + (freebsd_source_url . ,(or (freebsd-source-url source) "")) + (freebsd_source_path . ,(or (freebsd-source-path source) "")) + (freebsd_source_ref . ,(or (freebsd-source-ref source) "")) + (freebsd_source_commit . ,(or (freebsd-source-commit source) "")) + (freebsd_source_sha256 . ,(or (freebsd-source-sha256 source) "")) + (freebsd_source_file . ,(assoc-ref result 'freebsd-source-file)) + (freebsd_source_materializations_file . ,(assoc-ref result 'freebsd-source-materializations-file)) + (materialized_source_store_count . ,(length (assoc-ref result 'materialized-source-stores))) + (materialized_source_stores . ,(string-join (assoc-ref result 'materialized-source-stores) ",")) + (installer_host_name . ,(assoc-ref installer-iso-spec 'installer-host-name)) + (install_target_device . ,(assoc-ref result 'install-target-device)) + (iso_volume_label . ,(assoc-ref installer-iso-spec 'iso-volume-label)) + (root_size . ,(assoc-ref installer-iso-spec 'root-size)) + (installer_state_path . ,(assoc-ref result 'installer-state-path)) + (installer_log_path . ,(assoc-ref result 'installer-log-path)) + (iso_store_path . ,(assoc-ref result 'iso-store-path)) + (iso_image . ,(assoc-ref result 'iso-image)) + (boot_efi_image . ,(assoc-ref result 'boot-efi-image)) + (root_image . ,(assoc-ref result 'root-image)) + (installer_closure_path . ,(assoc-ref result 'installer-closure-path)) + (target_closure_path . ,(assoc-ref result 'target-closure-path)) + (host_base_store_count . ,(length host-base-stores)) + (host_base_stores . ,(string-join host-base-stores ",")) + (native_base_store_count . ,(length native-base-stores)) + (native_base_stores . ,(string-join native-base-stores ",")) + (fruix_runtime_store_count . ,(length fruix-runtime-stores)) + (fruix_runtime_stores . ,(string-join fruix-runtime-stores ",")) + (host_base_provenance_file . ,(assoc-ref result 'host-base-provenance-file)) + (store_layout_file . ,(assoc-ref result 'store-layout-file)) + (host_freebsd_version . ,(assoc-ref host-provenance 'freebsd-version-kru)) + (host_uname . ,(assoc-ref host-provenance 'uname)) + (usr_src_git_revision . ,(assoc-ref host-provenance 'usr-src-git-revision)) + (usr_src_git_branch . ,(assoc-ref host-provenance 'usr-src-git-branch)) + (usr_src_newvers_sha256 . ,(assoc-ref host-provenance 'usr-src-newvers-sha256)) + (store_item_count . ,(length store-items)) + (target_store_item_count . ,(length target-store-items)) + (installer_store_item_count . ,(length installer-store-items)))))) + +(define (emit-native-build-promotion-metadata store-dir result-root result) + (emit-metadata + `((action . "promote") + (result_root . ,result-root) + (store_dir . ,store-dir) + (executor_kind . ,(assoc-ref result 'executor-kind)) + (executor_name . ,(assoc-ref result 'executor-name)) + (executor_version . ,(assoc-ref result 'executor-version)) + (result_store . ,(assoc-ref result 'result-store)) + (result_metadata_file . ,(assoc-ref result 'result-metadata-file)) + (artifact_store_count . ,(assoc-ref result 'artifact-store-count)) + (artifact_stores . ,(string-join (assoc-ref result 'artifact-stores) ",")) + (world_store . ,(assoc-ref result 'world-store)) + (kernel_store . ,(assoc-ref result 'kernel-store)) + (headers_store . ,(assoc-ref result 'headers-store)) + (bootloader_store . ,(assoc-ref result 'bootloader-store))))) + +(define (shell-quote text) + (string-append "'" (string-replace-all text "'" "'\"'\"'") "'")) + +(define (command-success? program . args) + (zero? (apply system* program args))) + +(define* (ssh-base-args host #:key (user "root") (port "22") (identity-file #f)) + (append (list "-o" "BatchMode=yes" + "-o" "StrictHostKeyChecking=no" + "-o" "UserKnownHostsFile=/dev/null" + "-o" "ConnectTimeout=5" + "-p" port) + (if identity-file + (list "-i" identity-file) + '()) + (list (string-append user "@" host)))) + +(define* (ssh-command-prefix host #:key (user "root") (port "22") (identity-file #f)) + (string-join + (map shell-quote + (append (list "ssh") + (ssh-base-args host #:user user #:port port #:identity-file identity-file))) + " ")) + +(define* (ssh-shell-output host command #:key (user "root") (port "22") (identity-file #f)) + (trim-trailing-newlines + (apply command-output + "ssh" + (append (ssh-base-args host #:user user #:port port #:identity-file identity-file) + (list (string-append "set -eu; " command)))))) + +(define* (ssh-shell-success? host command #:key (user "root") (port "22") (identity-file #f)) + (apply command-success? + "ssh" + (append (ssh-base-args host #:user user #:port port #:identity-file identity-file) + (list (string-append "set -eu; " command))))) + +(define (metadata-value text key) + (let ((prefix (string-append key "="))) + (let loop ((lines (string-split text #\newline))) + (match lines + (() #f) + ((line . rest) + (if (string-prefix? prefix line) + (substring line (string-length prefix)) + (loop rest))))))) + +(define (system-closure-path? path) + (and (file-exists? path) + (file-exists? (string-append path "/activate")) + (file-exists? (string-append path "/shepherd/init.scm")) + (file-exists? (string-append path "/.references")))) + +(define* (remote-store-item-exists? host remote-item #:key (user "root") (port "22") (identity-file #f)) + (apply command-success? + "ssh" + (append (ssh-base-args host #:user user #:port port #:identity-file identity-file) + (list "test" "-e" remote-item)))) + +(define* (copy-store-item-to-remote item host remote-store-dir #:key (user "root") (port "22") (identity-file #f)) + (let* ((item-parent (dirname item)) + (item-base (path-basename item)) + (remote-command (string-append "set -eu; mkdir -p " (shell-quote remote-store-dir) + " && tar -xpf - -C " (shell-quote remote-store-dir))) + (command (string-append + "tar -cpf - -C " (shell-quote item-parent) " " (shell-quote item-base) + " | " + (ssh-command-prefix host #:user user #:port port #:identity-file identity-file) + " " (shell-quote remote-command)))) + (run-command "sh" "-eu" "-c" command))) + +(define* (wait-for-ssh host #:key (user "root") (port "22") (identity-file #f) (attempts 120) (delay 2)) + (let loop ((remaining attempts)) + (cond + ((ssh-shell-success? host "service sshd onestatus >/dev/null 2>&1" + #:user user #:port port #:identity-file identity-file) + #t) + ((<= remaining 0) + #f) + (else + (sleep delay) + (loop (- remaining 1)))))) + +(define* (deploy-system-closure closure-path host #:key (store-dir "/frx/store") + (user "root") (port "22") (identity-file #f) + (reboot? #f)) + (let* ((local-store-dir (dirname closure-path)) + (_ (unless (string=? local-store-dir store-dir) + (error "deploy expects closure to live under the selected store-dir" closure-path store-dir))) + (remote-closure-path (string-append store-dir "/" (path-basename closure-path))) + (references (store-reference-closure (list closure-path))) + (transferred '()) + (skipped '())) + (unless (ssh-shell-success? host "test -x /usr/local/bin/fruix" + #:user user #:port port #:identity-file identity-file) + (error "remote target is missing /usr/local/bin/fruix" host)) + (for-each + (lambda (item) + (let ((remote-item (string-append store-dir "/" (path-basename item)))) + (if (remote-store-item-exists? host remote-item + #:user user #:port port #:identity-file identity-file) + (set! skipped (cons remote-item skipped)) + (begin + (copy-store-item-to-remote item host store-dir + #:user user #:port port #:identity-file identity-file) + (set! transferred (cons remote-item transferred)))))) + references) + (let* ((switch-output + (ssh-shell-output host + (string-append "/usr/local/bin/fruix system switch " + (shell-quote remote-closure-path)) + #:user user #:port port #:identity-file identity-file)) + (deploy-current-generation (or (metadata-value switch-output "current_generation") "")) + (deploy-current-closure (or (metadata-value switch-output "current_closure") "")) + (deploy-rollback-generation (or (metadata-value switch-output "rollback_generation") "")) + (deploy-rollback-closure (or (metadata-value switch-output "rollback_closure") "")) + (reboot-completed? #f) + (remote-hostname "") + (remote-run-current "") + (remote-status-output switch-output)) + (when reboot? + (apply system* "ssh" + (append (ssh-base-args host #:user user #:port port #:identity-file identity-file) + (list "set -eu; shutdown -r now >/dev/null 2>&1 || reboot >/dev/null 2>&1 || true"))) + (sleep 5) + (unless (wait-for-ssh host #:user user #:port port #:identity-file identity-file) + (error "remote target did not return over SSH after deploy reboot" host)) + (set! reboot-completed? #t) + (set! remote-hostname + (ssh-shell-output host "hostname" #:user user #:port port #:identity-file identity-file)) + (set! remote-run-current + (ssh-shell-output host "readlink /run/current-system" #:user user #:port port #:identity-file identity-file)) + (set! remote-status-output + (ssh-shell-output host "/usr/local/bin/fruix system status" + #:user user #:port port #:identity-file identity-file))) + `((target-host . ,host) + (target-user . ,user) + (target-port . ,port) + (identity-file . ,(or identity-file "")) + (local-store-dir . ,store-dir) + (local-closure-path . ,closure-path) + (remote-closure-path . ,remote-closure-path) + (reference-count . ,(length references)) + (transfer-item-count . ,(length transferred)) + (skipped-item-count . ,(length skipped)) + (transferred-items . ,(reverse transferred)) + (skipped-items . ,(reverse skipped)) + (switch-output . ,switch-output) + (deploy-current-generation . ,deploy-current-generation) + (deploy-current-closure . ,deploy-current-closure) + (deploy-rollback-generation . ,deploy-rollback-generation) + (deploy-rollback-closure . ,deploy-rollback-closure) + (reboot-requested . ,reboot?) + (reboot-completed . ,reboot-completed?) + (remote-hostname . ,remote-hostname) + (remote-run-current . ,remote-run-current) + (remote-status-output . ,remote-status-output))))) + +(define (emit-system-deploy-metadata source-kind source-value os-file resolved-symbol store-dir result) + (emit-metadata + `((action . "deploy") + (source_kind . ,source-kind) + (source_value . ,source-value) + (os_file . ,(or os-file "")) + (system_variable . ,(or resolved-symbol "")) + (store_dir . ,store-dir) + (closure_path . ,(assoc-ref result 'local-closure-path)) + (remote_closure_path . ,(assoc-ref result 'remote-closure-path)) + (target_host . ,(assoc-ref result 'target-host)) + (target_user . ,(assoc-ref result 'target-user)) + (target_port . ,(assoc-ref result 'target-port)) + (identity_file . ,(assoc-ref result 'identity-file)) + (reference_count . ,(assoc-ref result 'reference-count)) + (transfer_item_count . ,(assoc-ref result 'transfer-item-count)) + (skipped_item_count . ,(assoc-ref result 'skipped-item-count)) + (deploy_current_generation . ,(assoc-ref result 'deploy-current-generation)) + (deploy_current_closure . ,(assoc-ref result 'deploy-current-closure)) + (deploy_rollback_generation . ,(assoc-ref result 'deploy-rollback-generation)) + (deploy_rollback_closure . ,(assoc-ref result 'deploy-rollback-closure)) + (reboot_requested . ,(assoc-ref result 'reboot-requested)) + (reboot_completed . ,(assoc-ref result 'reboot-completed)) + (remote_hostname . ,(assoc-ref result 'remote-hostname)) + (remote_run_current . ,(assoc-ref result 'remote-run-current))))) + +(define (main argv) + (let* ((parsed (parse-arguments argv)) + (command (assoc-ref parsed 'command)) + (action (assoc-ref parsed 'action)) + (store-dir (assoc-ref parsed 'store-dir))) + (cond + ((string=? command "system") + (let* ((positional (assoc-ref parsed 'positional)) + (disk-capacity (assoc-ref parsed 'disk-capacity)) + (root-size (assoc-ref parsed 'root-size)) + (target-opt (assoc-ref parsed 'target)) + (install-target-device (assoc-ref parsed 'install-target-device)) + (rootfs-opt (assoc-ref parsed 'rootfs)) + (deploy-host-opt (assoc-ref parsed 'deploy-host)) + (deploy-user (assoc-ref parsed 'deploy-user)) + (deploy-port (assoc-ref parsed 'deploy-port)) + (identity-file (assoc-ref parsed 'identity-file)) + (reboot? (assoc-ref parsed 'reboot?)) + (system-name (assoc-ref parsed 'system-name)) + (requested-symbol (and system-name (string->symbol system-name)))) + (unless (member action '("build" "deploy" "image" "installer" "installer-iso" "install" "rootfs")) + (error "unknown system action" action)) + (let* ((deploy-host (or deploy-host-opt + (and (string=? action "deploy") + (match positional + ((host . _) host) + (_ #f))))) + (os-file (and (not (string=? action "deploy")) + (match positional + ((file . _) file) + (() (error "missing operating-system file argument"))))) + (target (or target-opt + (and (string=? action "install") + (match positional + ((_ target-path) target-path) + (_ #f))))) + (rootfs (or rootfs-opt + (and (string=? action "rootfs") + (match positional + ((_ dir) dir) + ((_ _ dir . _) dir) + (_ #f)))))) + (cond + ((string=? action "deploy") + (unless deploy-host + (error "deploy action requires TARGET or --host HOST")) + (let* ((deploy-source (match positional + ((_ source . _) source) + ((_ _ source . _) source) + (_ #f))) + (guile-prefix (or (getenv "GUILE_PREFIX") "/tmp/guile-freebsd-validate-install")) + (guile-extra-prefix (or (getenv "GUILE_EXTRA_PREFIX") "/tmp/guile-gnutls-freebsd-validate-install")) + (shepherd-prefix (or (getenv "SHEPHERD_PREFIX") "/tmp/shepherd-freebsd-validate-install")) + (guile-store-path (getenv "FRUIX_GUILE_STORE")) + (guile-extra-store-path (getenv "FRUIX_GUILE_EXTRA_STORE")) + (shepherd-store-path (getenv "FRUIX_SHEPHERD_STORE"))) + (unless deploy-source + (error "deploy action requires a declaration file or system closure path")) + (if (system-closure-path? deploy-source) + (emit-system-deploy-metadata + "closure" deploy-source #f #f store-dir + (deploy-system-closure deploy-source deploy-host + #:store-dir store-dir + #:user deploy-user + #:port deploy-port + #:identity-file identity-file + #:reboot? reboot?)) + (call-with-values + (lambda () + (load-operating-system-from-file deploy-source requested-symbol)) + (lambda (os resolved-symbol) + (let* ((declaration-source (read-file-string deploy-source)) + (build-result + (materialize-operating-system os + #:store-dir store-dir + #:guile-prefix guile-prefix + #:guile-extra-prefix guile-extra-prefix + #:shepherd-prefix shepherd-prefix + #:guile-store-path guile-store-path + #:guile-extra-store-path guile-extra-store-path + #:shepherd-store-path shepherd-store-path + #:declaration-source declaration-source + #:declaration-origin deploy-source + #:declaration-system-symbol resolved-symbol))) + (emit-system-deploy-metadata + "declaration" deploy-source deploy-source resolved-symbol store-dir + (deploy-system-closure (assoc-ref build-result 'closure-path) deploy-host + #:store-dir store-dir + #:user deploy-user + #:port deploy-port + #:identity-file identity-file + #:reboot? reboot?)))))))) + ((not (string=? action "deploy")) + (call-with-values + (lambda () + (load-operating-system-from-file os-file requested-symbol)) + (lambda (os resolved-symbol) + (let* ((guile-prefix (or (getenv "GUILE_PREFIX") "/tmp/guile-freebsd-validate-install")) + (guile-extra-prefix (or (getenv "GUILE_EXTRA_PREFIX") "/tmp/guile-gnutls-freebsd-validate-install")) + (shepherd-prefix (or (getenv "SHEPHERD_PREFIX") "/tmp/shepherd-freebsd-validate-install")) + (guile-store-path (getenv "FRUIX_GUILE_STORE")) + (guile-extra-store-path (getenv "FRUIX_GUILE_EXTRA_STORE")) + (shepherd-store-path (getenv "FRUIX_SHEPHERD_STORE")) + (declaration-source (read-file-string os-file))) + (cond + ((string=? action "build") + (emit-system-build-metadata + os-file resolved-symbol store-dir os + (materialize-operating-system os + #:store-dir store-dir + #:guile-prefix guile-prefix + #:guile-extra-prefix guile-extra-prefix + #:shepherd-prefix shepherd-prefix + #:guile-store-path guile-store-path + #:guile-extra-store-path guile-extra-store-path + #:shepherd-store-path shepherd-store-path + #:declaration-source declaration-source + #:declaration-origin os-file + #:declaration-system-symbol resolved-symbol))) + ((string=? action "rootfs") + (unless rootfs + (error "rootfs action requires ROOTFS-DIR or --rootfs DIR")) + (let ((result (materialize-rootfs os rootfs + #:store-dir store-dir + #:guile-prefix guile-prefix + #:guile-extra-prefix guile-extra-prefix + #:shepherd-prefix shepherd-prefix + #:declaration-source declaration-source + #:declaration-origin os-file + #:declaration-system-symbol resolved-symbol))) + (emit-metadata + `((action . "rootfs") + (os_file . ,os-file) + (system_variable . ,resolved-symbol) + (store_dir . ,store-dir) + (rootfs . ,(assoc-ref result 'rootfs)) + (closure_path . ,(assoc-ref result 'closure-path)) + (ready_marker . ,(assoc-ref result 'ready-marker)) + (rc_script . ,(assoc-ref result 'rc-script)))))) + ((string=? action "image") + (emit-system-image-metadata + os-file resolved-symbol store-dir os + (materialize-bhyve-image os + #:store-dir store-dir + #:guile-prefix guile-prefix + #:guile-extra-prefix guile-extra-prefix + #:shepherd-prefix shepherd-prefix + #:declaration-source declaration-source + #:declaration-origin os-file + #:declaration-system-symbol resolved-symbol + #:root-size (or root-size "256m") + #:disk-capacity disk-capacity))) + ((string=? action "installer") + (emit-system-installer-metadata + os-file resolved-symbol store-dir os + (materialize-installer-image os + #:store-dir store-dir + #:guile-prefix guile-prefix + #:guile-extra-prefix guile-extra-prefix + #:shepherd-prefix shepherd-prefix + #:declaration-source declaration-source + #:declaration-origin os-file + #:declaration-system-symbol resolved-symbol + #:install-target-device (or install-target-device "/dev/vtbd1") + #:root-size (or root-size "10g") + #:disk-capacity disk-capacity))) + ((string=? action "installer-iso") + (emit-system-installer-iso-metadata + os-file resolved-symbol store-dir os + (materialize-installer-iso os + #:store-dir store-dir + #:guile-prefix guile-prefix + #:guile-extra-prefix guile-extra-prefix + #:shepherd-prefix shepherd-prefix + #:declaration-source declaration-source + #:declaration-origin os-file + #:declaration-system-symbol resolved-symbol + #:install-target-device (or install-target-device "/dev/vtbd0") + #:root-size root-size))) + ((string=? action "install") + (unless target + (error "install action requires TARGET or --target PATH")) + (emit-system-install-metadata + os-file resolved-symbol store-dir os + (install-operating-system os + #:target target + #:store-dir store-dir + #:guile-prefix guile-prefix + #:guile-extra-prefix guile-extra-prefix + #:shepherd-prefix shepherd-prefix + #:declaration-source declaration-source + #:declaration-origin os-file + #:declaration-system-symbol resolved-symbol + #:root-size root-size + #:disk-capacity disk-capacity)))))))))))) + ((string=? command "source") + (let* ((positional (assoc-ref parsed 'positional)) + (cache-dir (assoc-ref parsed 'cache-dir)) + (source-name (assoc-ref parsed 'source-name)) + (requested-symbol (and source-name (string->symbol source-name)))) + (unless (string=? action "materialize") + (error "unknown source action" action)) + (let ((source-file (match positional + ((file . _) file) + (() (error "missing freebsd-source file argument"))))) + (call-with-values + (lambda () + (load-freebsd-source-from-file source-file requested-symbol)) + (lambda (source resolved-symbol) + (let* ((result (materialize-freebsd-source source + #:store-dir store-dir + #:cache-dir cache-dir)) + (effective (assoc-ref result 'effective-source))) + (emit-metadata + `((action . "materialize") + (source_file . ,source-file) + (source_variable . ,resolved-symbol) + (store_dir . ,store-dir) + (cache_dir . ,cache-dir) + (freebsd_source_name . ,(freebsd-source-name source)) + (freebsd_source_kind . ,(freebsd-source-kind source)) + (freebsd_source_url . ,(or (freebsd-source-url source) "")) + (freebsd_source_path . ,(or (freebsd-source-path source) "")) + (freebsd_source_ref . ,(or (freebsd-source-ref source) "")) + (freebsd_source_commit . ,(or (freebsd-source-commit source) "")) + (freebsd_source_sha256 . ,(or (freebsd-source-sha256 source) "")) + (materialized_source_store . ,(assoc-ref result 'source-store-path)) + (materialized_source_root . ,(assoc-ref result 'source-root)) + (materialized_source_info_file . ,(assoc-ref result 'source-info-file)) + (materialized_source_tree_sha256 . ,(assoc-ref result 'source-tree-sha256)) + (materialized_source_cache_path . ,(or (assoc-ref result 'cache-path) "")) + (materialized_source_kind . ,(assoc-ref effective 'kind)) + (materialized_source_url . ,(or (assoc-ref effective 'url) "")) + (materialized_source_path . ,(or (assoc-ref effective 'path) "")) + (materialized_source_ref . ,(or (assoc-ref effective 'ref) "")) + (materialized_source_commit . ,(or (assoc-ref result 'effective-commit) "")) + (materialized_source_sha256 . ,(or (assoc-ref result 'effective-sha256) "")))))))))) + ((string=? command "native-build") + (let ((positional (assoc-ref parsed 'positional))) + (unless (string=? action "promote") + (error "unknown native-build action" action)) + (let ((result-root (match positional + ((path . _) path) + (() (error "missing native build result root argument"))))) + (emit-native-build-promotion-metadata + store-dir result-root + (promote-native-build-result result-root #:store-dir store-dir))))) + (#t + (usage 1))))) + +(main (command-line))