self/fruix
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Reuse jailed merge policy for package profiles

Browse Source
This commit is contained in:
Steffen Beyer
2026-04-09 16:04:55 +02:00
parent 94b6cd9841
commit 9d090d5e73
4 changed files with 310 additions and 38 deletions
Download Patch File Download Diff File Expand all files Collapse all files
modules/fruix/system/freebsd/build.scm
+221 -9
View File
@@ -20,6 +20,7 @@
promoted-native-build-result-development-packages
operating-system-from-promoted-native-build-result
materialize-freebsd-package
materialize-package-profile-tree
promote-native-build-result
materialize-prefix))
@@ -351,6 +352,106 @@
("TMPDIR" . "/tmp")
("USER" . ,effective-user))))
(define (string-trueish? value)
(and value
(member (string-downcase value)
'("1" "true" "yes" "on"))))
(define (build-jail-default-keep-root?)
(not (not (string-trueish? (getenv "FRUIX_BUILD_JAIL_KEEP_ROOT")))))
(define (absolute-path? path)
(and (string? path)
(string-prefix? "/" path)))
(define (safe-absolute-path? path)
(and (absolute-path? path)
(null? (filter (lambda (segment)
(member segment '("." "..")))
(string-split path #\/)))))
(define (require-safe-absolute-path who path)
(unless (safe-absolute-path? path)
(error who "expected a safe absolute path" path))
path)
(define reserved-build-jail-targets
'("/build.sh" "/run.sh"))
(define (build-jail-root-base)
(let ((root-base (or (getenv "FRUIX_BUILD_JAIL_ROOT_BASE")
"/tmp")))
(require-safe-absolute-path "build-jail-root-base" root-base)
root-base))
(define (jail-mount-spec-target spec)
(match spec
(('nullfs _ target _) target)
(('devfs target) target)
(_ (error "invalid jail mount spec" spec))))
(define (jail-mount-spec-source spec)
(match spec
(('nullfs source _ _) source)
(('devfs _) #f)
(_ (error "invalid jail mount spec" spec))))
(define (duplicate-strings values)
(let loop ((rest values)
(seen '())
(duplicates '()))
(match rest
(() (reverse duplicates))
((value . tail)
(if (member value seen)
(loop tail seen
(if (member value duplicates)
duplicates
(cons value duplicates)))
(loop tail (cons value seen) duplicates))))))
(define (validate-build-jail-config config)
(let* ((workdir (build-jail-config-value config 'workdir "/tmp"))
(home (build-jail-config-value config 'home #f))
(directories (build-jail-effective-directories config))
(mount-specs (build-jail-config-mounts config))
(targets (map jail-mount-spec-target mount-specs))
(rw-targets (filter-map (lambda (spec)
(match spec
(('nullfs _ target 'rw) target)
(_ #f)))
mount-specs))
(duplicate-targets (duplicate-strings targets)))
(require-safe-absolute-path "build-jail workdir" workdir)
(when home
(require-safe-absolute-path "build-jail home" home))
(for-each (lambda (directory)
(require-safe-absolute-path "build-jail directory" directory))
directories)
(for-each (lambda (spec)
(let ((target (jail-mount-spec-target spec))
(source (jail-mount-spec-source spec)))
(require-safe-absolute-path "build-jail mount target" target)
(when (member target reserved-build-jail-targets)
(error "build-jail mount target is reserved" target))
(when source
(require-safe-absolute-path "build-jail mount source" source)
(unless (file-exists? source)
(error "build-jail mount source does not exist" source)))))
mount-specs)
(unless (null? duplicate-targets)
(error "build-jail mount targets must be unique" duplicate-targets))
(for-each (lambda (left)
(for-each (lambda (right)
(when (and (not (string=? left right))
(or (path-covered-by-root? left right)
(path-covered-by-root? right left)))
(error "build-jail writable mount targets must not overlap"
(list left right))))
rw-targets))
rw-targets)
config))
(define (build-jail-base-config executor)
(let* ((user (or (native-build-executor-property-ref executor 'user #f)
(current-user-name)))
@@ -374,7 +475,8 @@
#:directories (or (native-build-executor-property-ref executor 'directories #f)
'())
#:metadata-file (native-build-executor-property-ref executor 'metadata-file #f)
#:keep-root? (native-build-executor-property-ref executor 'keep-root? #f))))
#:keep-root? (or (native-build-executor-property-ref executor 'keep-root? #f)
(build-jail-default-keep-root?)))))
(define (build-jail-config-merge base override)
(build-jail-config
@@ -569,6 +671,7 @@
`((executor . ,executor)
(name . ,jail-name)
(root . ,jail-root)
(keep-root? . ,(build-jail-config-value config 'keep-root? #f))
(network? . ,(build-jail-config-value config 'network? #f))
(user . ,(build-jail-config-value config 'user #f))
(home . ,(build-jail-config-value config 'home #f))
@@ -585,16 +688,20 @@
config
(mounts '())
(directories '("/tmp")))
(let* ((effective-config (build-jail-config-merge
(let* ((effective-config (validate-build-jail-config
(build-jail-config-merge
(build-jail-base-config executor)
(build-jail-config #:name name
#:mounts mounts
#:directories directories))
(or config
(build-jail-config))))
(build-jail-config-merge
(build-jail-base-config executor)
(build-jail-config #:name name
#:mounts mounts
#:directories directories))
(or config
(build-jail-config)))))
(mount-specs (build-jail-config-mounts effective-config))
(jail-root (mktemp-directory "/tmp/fruix-build-jail.XXXXXX"))
(jail-root-base (build-jail-root-base))
(jail-root (begin
(mkdir-p jail-root-base)
(mktemp-directory (string-append jail-root-base "/fruix-build-jail.XXXXXX"))))
(script-path (string-append jail-root "/build.sh"))
(runner-path (string-append jail-root "/run.sh"))
(jail-name (string-append (or (build-jail-config-value effective-config 'name #f)
@@ -674,6 +781,111 @@
(map host-path->jail-mount-pair
(filter file-exists? copy-build-mounted-host-paths)))
(define (merge-tree-node source destination)
(let ((kind (stat:type (lstat source))))
(case kind
((directory)
(mkdir-p destination)
(for-each (lambda (entry)
(merge-tree-node (string-append source "/" entry)
(string-append destination "/" entry)))
(directory-entries source)))
((symlink)
(unless (or (file-exists? destination)
(false-if-exception (readlink destination)))
(mkdir-p (dirname destination))
(symlink (readlink source) destination)))
(else
(unless (file-exists? destination)
(mkdir-p (dirname destination))
(copy-node source destination))))))
(define (merge-package-output-into-tree source-root target-root)
(mkdir-p target-root)
(for-each (lambda (entry)
(unless (string-prefix? "." entry)
(merge-tree-node (string-append source-root "/" entry)
(string-append target-root "/" entry))))
(directory-entries source-root)))
(define (package-profile-merge-jail-script source-roots target-root)
(string-append
"#!/bin/sh\n"
"set -eu\n"
"merge_node() {\n"
" if [ -d \"$1\" ] && [ ! -L \"$1\" ]; then\n"
" mkdir -p \"$2\"\n"
" for entry in \"$1\"/* \"$1\"/.[!.]* \"$1\"/..?*; do\n"
" [ -e \"$entry\" ] || [ -L \"$entry\" ] || continue\n"
" merge_node \"$entry\" \"$2/$(basename \"$entry\")\"\n"
" done\n"
" elif [ -L \"$1\" ]; then\n"
" if [ ! -e \"$2\" ] && [ ! -L \"$2\" ]; then\n"
" mkdir -p \"$(dirname \"$2\")\"\n"
" ln -s \"$(readlink \"$1\")\" \"$2\"\n"
" fi\n"
" else\n"
" if [ ! -e \"$2\" ] && [ ! -L \"$2\" ]; then\n"
" mkdir -p \"$(dirname \"$2\")\"\n"
" cp -p \"$1\" \"$2\"\n"
" fi\n"
" fi\n"
"}\n"
"merge_root() {\n"
" mkdir -p \"$2\"\n"
" for entry in \"$1\"/* \"$1\"/.[!.]* \"$1\"/..?*; do\n"
" [ -e \"$entry\" ] || [ -L \"$entry\" ] || continue\n"
" case \"$(basename \"$entry\")\" in\n"
" .references|.fruix-package|.*)\n"
" continue\n"
" ;;\n"
" esac\n"
" merge_node \"$entry\" \"$2/$(basename \"$entry\")\"\n"
" done\n"
"}\n"
(string-concatenate
(map (lambda (source-root)
(string-append "merge_root "
(shell-quote source-root)
" "
(shell-quote target-root)
"\n"))
source-roots))))
(define (package-profile-tree-metadata executor source-roots output-path)
`((executor . ,executor)
(output-path . ,output-path)
(source-roots . ,source-roots)))
(define* (materialize-package-profile-tree source-roots output-path #:key metadata-file)
(mkdir-p output-path)
(let* ((normalized-source-roots (delete-duplicates source-roots string=?))
(executor (default-copy-build-executor)))
(case (native-build-executor-kind executor)
((jail)
(run-script-in-temporary-jail
executor
(package-profile-merge-jail-script normalized-source-roots output-path)
#:config (build-jail-config
#:name "fruix-package-profile"
#:read-only-mounts (append (copy-build-read-only-mounts)
(map host-path->jail-mount-pair normalized-source-roots))
#:writable-mounts (list (cons output-path output-path))
#:mounts (list (jail-devfs-mount "/dev"))
#:workdir output-path
#:directories '("/tmp" "/dev")
#:metadata-file metadata-file)))
(else
(for-each (lambda (source-root)
(merge-package-output-into-tree source-root output-path))
normalized-source-roots)
(when metadata-file
(mkdir-p (dirname metadata-file))
(write-file metadata-file
(object->string
(package-profile-tree-metadata executor normalized-source-roots output-path)))))))
output-path)
(define (native-build-extra-host-paths common)
(let ((candidate-paths (filter identity
(list (assoc-ref common 'source-root)
scripts/fruix.scm
+11 -29
View File
@@ -798,31 +798,6 @@ Common options:\n\
(delete-path-if-exists link-name)
(symlink target link-name))
(define (merge-node source destination)
(let ((kind (stat:type (lstat source))))
(case kind
((directory)
(mkdir-p destination)
(for-each (lambda (entry)
(merge-node (string-append source "/" entry)
(string-append destination "/" entry)))
(directory-entries source)))
((symlink)
(unless (path-present? destination)
(mkdir-p (path-directory destination))
(symlink (readlink source) destination)))
(else
(unless (file-exists? destination)
(copy-node source destination))))))
(define (merge-package-output source-root target-root)
(mkdir-p target-root)
(for-each (lambda (entry)
(unless (string-prefix? "." entry)
(merge-node (string-append source-root "/" entry)
(string-append target-root "/" entry))))
(directory-entries source-root)))
(define (package-profile-activate-script)
(string-append
"#!/bin/sh\n"
@@ -870,12 +845,12 @@ Common options:\n\
(packages . ,normalized)
(package-stores . ,package-stores))))
(profile-store (make-store-path store-dir "fruix-package-profile" payload
#:kind 'profile)))
#:kind 'profile))
(profile-jail-metadata-file (string-append profile-store "/.fruix-build-jail.scm")))
(unless (file-exists? profile-store)
(mkdir-p profile-store)
(for-each (lambda (store)
(merge-package-output store profile-store))
package-stores)
(materialize-package-profile-tree package-stores profile-store
#:metadata-file profile-jail-metadata-file)
(write-file (string-append profile-store "/.references")
(string-join package-stores "\n"))
(write-file (string-append profile-store "/.fruix-profile.scm")
@@ -886,6 +861,7 @@ Common options:\n\
(package-profile-activate-script))
(chmod (string-append profile-store "/activate") #o555))
`((profile-store . ,profile-store)
(profile-jail-metadata-file . ,profile-jail-metadata-file)
(package-stores . ,package-stores)
(packages . ,normalized))))
@@ -919,6 +895,9 @@ Common options:\n\
`((profile-dir . ,profile-dir)
(generation . ,generation)
(profile-store . ,profile-store)
(profile-jail-metadata-file . ,(match (assoc 'profile-jail-metadata-file materialized)
((_ . value) value)
(#f #f)))
(current-link . ,current-link)
(activate-link . ,activate-link)
(manifest-path . ,manifest-path)
@@ -932,6 +911,9 @@ Common options:\n\
(profile_dir . ,(assoc-ref result 'profile-dir))
(generation . ,(assoc-ref result 'generation))
(profile_store . ,(assoc-ref result 'profile-store))
(profile_jail_metadata_file . ,(match (assoc 'profile-jail-metadata-file result)
((_ . value) value)
(#f #f)))
(current_link . ,(assoc-ref result 'current-link))
(activate_link . ,(assoc-ref result 'activate-link))
(manifest_path . ,(assoc-ref result 'manifest-path))
tests/build-jails.scm
+70
View File
@@ -31,6 +31,9 @@
(define (trim text)
(string-trim-both text))
(define (read-scheme-file path)
(call-with-input-file path read))
(test-begin "build-jails")
(let ((executor (default-copy-build-executor)))
@@ -79,6 +82,26 @@
(and (not (string-contains networked-command " ip4=disable"))
(not (string-contains networked-command " ip6=disable")))))
(test-assert "jail runner rejects relative mount targets"
(not (false-if-exception
(run-script-in-temporary-jail
(jail-native-build-executor)
"#!/bin/sh\nset -eu\n"
#:config (build-jail-config
#:read-only-mounts (list (cons "/bin" "bin")))))))
(let ((config #f))
(dynamic-wind
(lambda ()
(setenv "FRUIX_BUILD_JAIL_KEEP_ROOT" "1"))
(lambda ()
(set! config (build-jail-base-config (jail-native-build-executor))))
(lambda ()
(unsetenv "FRUIX_BUILD_JAIL_KEEP_ROOT")))
(test-equal "jail build config honors keep-root override"
#t
(build-jail-config-ref config 'keep-root? #f)))
(when (jail-build-available?)
(let* ((executor (default-copy-build-executor))
(output-dir (mktemp-directory "/tmp/fruix-build-jails-copy.XXXXXX"))
@@ -129,6 +152,53 @@
(test-assert "generic jail runner preserves whitelisted TMPDIR"
(string-contains env-text "TMPDIR=/tmp")))))
(when (jail-build-available?)
(let* ((executor (default-copy-build-executor))
(root-base (mktemp-directory "/tmp/fruix-build-jails-keep-root.XXXXXX"))
(output-dir (mktemp-directory "/tmp/fruix-build-jails-keep-root-out.XXXXXX"))
(metadata-file (string-append output-dir "/jail-metadata.scm"))
(config (build-jail-config
#:name "fruix-build-jails-keep-root"
#:read-only-mounts (list (cons "/bin" "/bin")
(cons "/lib" "/lib")
(cons "/libexec" "/libexec")
(cons "/usr" "/usr")
(cons "/etc" "/etc"))
#:writable-mounts (list (cons output-dir "/out"))
#:mounts (list (jail-devfs-mount "/dev"))
#:workdir "/out"
#:directories '("/tmp" "/dev" "/out")
#:metadata-file metadata-file)))
(dynamic-wind
(lambda ()
(setenv "FRUIX_BUILD_JAIL_KEEP_ROOT" "1")
(setenv "FRUIX_BUILD_JAIL_ROOT_BASE" root-base))
(lambda ()
(run-script-in-temporary-jail
executor
(string-append "#!/bin/sh\n"
"set -eu\n"
"printf kept > /out/result\n")
#:config config))
(lambda ()
(unsetenv "FRUIX_BUILD_JAIL_KEEP_ROOT")
(unsetenv "FRUIX_BUILD_JAIL_ROOT_BASE")))
(let* ((metadata (read-scheme-file metadata-file))
(root-entry (assoc 'root metadata))
(keep-root-entry (assoc 'keep-root? metadata))
(kept-root (and root-entry (cdr root-entry))))
(test-equal "generic jail runner metadata records keep-root"
#t
(and keep-root-entry (cdr keep-root-entry)))
(test-assert "generic jail runner keeps jail root when requested"
(and kept-root
(string-prefix? root-base kept-root)
(file-exists? kept-root)))
(when kept-root
(delete-path-if-exists kept-root)))
(delete-path-if-exists root-base)
(delete-path-if-exists output-dir)))
(let* ((executor (default-native-build-executor))
(build-root (mktemp-directory "/tmp/fruix-build-jails-native.XXXXXX"))
(log-file (string-append build-root "/logs/make-vars.log"))
tests/package-profile.scm
+8
View File
@@ -71,6 +71,7 @@
(activate-link (string-append profile-dir "/activate"))
(manifest-path (string-append profile-dir "/manifest.scm"))
(first-profile-store (metadata-value install-output "profile_store"))
(first-profile-jail-metadata-file (metadata-value install-output "profile_jail_metadata_file"))
(second-profile-store (metadata-value install-output-2 "profile_store"))
(third-profile-store (metadata-value remove-output "profile_store")))
(test-equal "package install reports action"
@@ -91,6 +92,13 @@
(path-present? (string-append first-profile-store "/bin/npm")))
(test-assert "activate script exists in the first profile store"
(path-present? (string-append first-profile-store "/activate")))
(test-assert "profile materialization records jail metadata"
(and first-profile-jail-metadata-file
(file-exists? first-profile-jail-metadata-file)))
(when first-profile-jail-metadata-file
(let ((metadata-text (command-output "cat" first-profile-jail-metadata-file)))
(test-assert "profile jail metadata records network disabled"
(string-contains metadata-text "(network? . #f)"))))
(test-assert "installed lists nodejs after first install"
(member "freebsd-nodejs"
(map summary-line-name (output-lines installed-output-1))))