Handle unreadable host inputs in system builds

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

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"

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))

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")