From 9d090d5e732af9c64e7b8f241d5e735633014668 Mon Sep 17 00:00:00 2001 From: Steffen Beyer Date: Thu, 9 Apr 2026 16:04:55 +0200 Subject: [PATCH] Reuse jailed merge policy for package profiles --- modules/fruix/system/freebsd/build.scm | 230 ++++++++++++++++++++++++- scripts/fruix.scm | 40 ++--- tests/build-jails.scm | 70 ++++++++ tests/package-profile.scm | 8 + 4 files changed, 310 insertions(+), 38 deletions(-) diff --git a/modules/fruix/system/freebsd/build.scm b/modules/fruix/system/freebsd/build.scm index eb24042..f977a8a 100644 --- a/modules/fruix/system/freebsd/build.scm +++ b/modules/fruix/system/freebsd/build.scm @@ -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) diff --git a/scripts/fruix.scm b/scripts/fruix.scm index 0287e15..1c39fc5 100644 --- a/scripts/fruix.scm +++ b/scripts/fruix.scm @@ -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)) diff --git a/tests/build-jails.scm b/tests/build-jails.scm index 6beed03..f78a02e 100644 --- a/tests/build-jails.scm +++ b/tests/build-jails.scm @@ -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")) diff --git a/tests/package-profile.scm b/tests/package-profile.scm index a7dd51c..af0d079 100644 --- a/tests/package-profile.scm +++ b/tests/package-profile.scm @@ -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))))