diff --git a/modules/fruix/packages/freebsd.scm b/modules/fruix/packages/freebsd.scm index 083af17..2af2706 100644 --- a/modules/fruix/packages/freebsd.scm +++ b/modules/fruix/packages/freebsd.scm @@ -406,7 +406,9 @@ files needed by the first Fruix system-closure experiments." (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")))) + (file "/etc/defaults/bluetooth.device.conf" "etc/defaults/bluetooth.device.conf") + (file "/etc/defaults/periodic.conf" "etc/defaults/periodic.conf") + (file "/etc/defaults/rc.conf" "etc/defaults/rc.conf")))) (define freebsd-runtime (freebsd-package diff --git a/modules/fruix/system/freebsd/build.scm b/modules/fruix/system/freebsd/build.scm index ad4a0da..6ee93a1 100644 --- a/modules/fruix/system/freebsd/build.scm +++ b/modules/fruix/system/freebsd/build.scm @@ -564,6 +564,20 @@ (path-covered-by-root? path root)) roots)) +(define (minimal-path-roots paths) + (fold (lambda (path kept) + (if (path-covered-by-any-root? path kept) + kept + (cons path + (filter (lambda (root) + (not (path-covered-by-root? root path))) + kept)))) + '() + (sort (delete-duplicates paths string=?) + (lambda (left right) + (< (string-length left) + (string-length right)))))) + (define (jail-root-target jail-root target) (string-append jail-root target)) @@ -840,6 +854,23 @@ (map host-path->jail-mount-pair (filter file-exists? copy-build-mounted-host-paths))) +(define (copy-build-extra-host-paths package) + (minimal-path-roots + (filter (lambda (path) + (and (file-exists? path) + (not (path-covered-by-any-root? path + copy-build-mounted-host-paths)))) + (filter-map (lambda (entry) + (match entry + (('file source _) + (and (string? source) + (dirname source))) + (('directory source _) + (and (string? source) + source)) + (_ #f))) + (freebsd-package-install-plan package))))) + (define union-tree-mounted-host-paths '("/bin" "/lib" @@ -1079,14 +1110,14 @@ #:name "fruix-package-profile")) (define (native-build-extra-host-paths common) - (let ((candidate-paths (filter identity - (list (assoc-ref common 'source-root) - (dirname (assoc-ref common 'kernconf-path)))))) - (filter (lambda (path) - (and (file-exists? path) - (not (path-covered-by-any-root? path - native-build-mounted-host-paths)))) - candidate-paths))) + (minimal-path-roots + (filter (lambda (path) + (and (file-exists? path) + (not (path-covered-by-any-root? path + native-build-mounted-host-paths)))) + (filter identity + (list (assoc-ref common 'source-root) + (dirname (assoc-ref common 'kernconf-path))))))) (define (native-build-read-only-mounts common) (map host-path->jail-mount-pair @@ -1096,7 +1127,9 @@ (define (copy-build-jail-config package output-path) (build-jail-config #:name (string-append "fruix-copy-" (freebsd-package-name package)) - #:read-only-mounts (copy-build-read-only-mounts) + #:read-only-mounts (append (copy-build-read-only-mounts) + (map host-path->jail-mount-pair + (copy-build-extra-host-paths package))) #:writable-mounts (list (cons output-path "/out")) #:mounts (list (jail-devfs-mount "/dev")) #:workdir "/out" diff --git a/tests/build-jails.scm b/tests/build-jails.scm index 4df1932..1483ecc 100644 --- a/tests/build-jails.scm +++ b/tests/build-jails.scm @@ -1,6 +1,7 @@ (use-modules (srfi srfi-13) (srfi srfi-64) (guix build utils) + (fruix packages freebsd) (fruix system freebsd build) (fruix system freebsd executor) (fruix system freebsd utils)) @@ -29,6 +30,8 @@ (@@ (fruix system freebsd build) build-jail-command-string)) (define materialize-union-tree (@@ (fruix system freebsd build) materialize-union-tree)) +(define copy-build-extra-host-paths + (@@ (fruix system freebsd build) copy-build-extra-host-paths)) (define (trim text) (string-trim-both text)) @@ -48,6 +51,13 @@ (if (jail-build-available?) 'jail 'host) (native-build-executor-kind executor))) +(test-assert "copy build discovers extra host paths outside default mounts" + (member "/boot/kernel" + (copy-build-extra-host-paths freebsd-kernel))) +(test-equal "copy build extra host paths collapse overlapping boot roots" + '("/boot") + (copy-build-extra-host-paths freebsd-bootloader)) + (let* ((config (build-jail-base-config (jail-native-build-executor))) (env (build-jail-config-ref config 'env '())) (path-entry (assoc "PATH" env)) diff --git a/tests/console-defaults.scm b/tests/console-defaults.scm index 16ca551..fd8bc08 100644 --- a/tests/console-defaults.scm +++ b/tests/console-defaults.scm @@ -24,6 +24,7 @@ (define userland-targets (install-targets freebsd-userland)) (define runtime-targets (install-targets freebsd-runtime)) +(define rc-script-targets (install-targets freebsd-rc-scripts)) (test-begin "console-defaults") @@ -58,5 +59,12 @@ "usr/bin/who" "usr/bin/last" "usr/libexec/getty"))) (test-assert "runtime stages gettytab" (member "etc/gettytab" runtime-targets)) +(test-assert "rc scripts stage readable defaults files explicitly" + (every (lambda (target) (member target rc-script-targets)) + '("etc/defaults/bluetooth.device.conf" + "etc/defaults/periodic.conf" + "etc/defaults/rc.conf"))) +(test-assert "rc scripts do not stage entire defaults directory" + (not (member "etc/defaults" rc-script-targets))) (test-end "console-defaults")