channel: import canonical fruix code
This commit is contained in:
@@ -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
|
||||
```
|
||||
|
||||
@@ -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" "$@"
|
||||
@@ -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 <freebsd-package>
|
||||
(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 <freebsd-source>
|
||||
(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 <freebsd-base>
|
||||
(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)
|
||||
@@ -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))
|
||||
@@ -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))
|
||||
@@ -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))
|
||||
|
||||
@@ -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)))))
|
||||
File diff suppressed because it is too large
Load Diff
@@ -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 <user-group>
|
||||
(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 <user-account>
|
||||
(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 <file-system>
|
||||
(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 <promoted-native-build-result>
|
||||
(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 <operating-system>
|
||||
(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 <freebsd-source> 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 <freebsd-base> record"))
|
||||
(when native-build-result
|
||||
(unless (promoted-native-build-result? native-build-result)
|
||||
(error "operating-system native-build-result must be a <promoted-native-build-result> record")))
|
||||
(unless (every freebsd-package? base-packages)
|
||||
(error "operating-system base-packages must be a list of <freebsd-package> records"))
|
||||
(unless (every freebsd-package? development-packages)
|
||||
(error "operating-system development-packages must be a list of <freebsd-package> records"))
|
||||
(unless (every freebsd-package? build-packages)
|
||||
(error "operating-system build-packages must be a list of <freebsd-package> 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))))
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -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))))
|
||||
|
||||
@@ -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))
|
||||
string<?))
|
||||
|
||||
(define (path-signature path)
|
||||
(let ((st (lstat path)))
|
||||
(case (stat:type st)
|
||||
((regular)
|
||||
(string-append "file:" path ":" (file-hash path)))
|
||||
((symlink)
|
||||
(string-append "symlink:" path ":" (readlink path)))
|
||||
((directory)
|
||||
(string-join
|
||||
(cons (string-append "directory:" path)
|
||||
(apply append
|
||||
(map (lambda (entry)
|
||||
(list (path-signature (string-append path "/" entry))))
|
||||
(directory-entries path))))
|
||||
"\n"))
|
||||
(else
|
||||
(string-append "other:" path ":" (symbol->string (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))
|
||||
|
||||
+1072
File diff suppressed because it is too large
Load Diff
Reference in New Issue
Block a user