281 lines
13 KiB
Scheme
281 lines
13 KiB
Scheme
(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))
|
|
|
|
(define jail-build-available?
|
|
(@@ (fruix system freebsd build) jail-build-available?))
|
|
(define default-copy-build-executor
|
|
(@@ (fruix system freebsd build) default-copy-build-executor))
|
|
(define default-native-build-executor
|
|
(@@ (fruix system freebsd build) default-native-build-executor))
|
|
(define jail-devfs-mount
|
|
(@@ (fruix system freebsd build) jail-devfs-mount))
|
|
(define run-script-in-temporary-jail
|
|
(@@ (fruix system freebsd build) run-script-in-temporary-jail))
|
|
(define run-command/log-with-executor
|
|
(@@ (fruix system freebsd build) run-command/log-with-executor))
|
|
(define native-install-command-string
|
|
(@@ (fruix system freebsd build) native-install-command-string))
|
|
(define build-jail-config
|
|
(@@ (fruix system freebsd build) build-jail-config))
|
|
(define build-jail-config-ref
|
|
(@@ (fruix system freebsd build) build-jail-config-ref))
|
|
(define build-jail-base-config
|
|
(@@ (fruix system freebsd build) build-jail-base-config))
|
|
(define build-jail-command-string
|
|
(@@ (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))
|
|
|
|
(define (read-scheme-file path)
|
|
(call-with-input-file path read))
|
|
|
|
(test-begin "build-jails")
|
|
|
|
(let ((executor (default-copy-build-executor)))
|
|
(test-equal "copy build executor matches jail availability"
|
|
(if (jail-build-available?) 'jail 'host)
|
|
(native-build-executor-kind executor)))
|
|
|
|
(let ((executor (default-native-build-executor)))
|
|
(test-equal "native build executor matches jail availability"
|
|
(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))
|
|
(tmpdir-entry (assoc "TMPDIR" env)))
|
|
(test-equal "jail build config disables network by default"
|
|
#f
|
|
(build-jail-config-ref config 'network? #t))
|
|
(test-equal "jail build config defaults to /tmp workdir"
|
|
"/tmp"
|
|
(build-jail-config-ref config 'workdir #f))
|
|
(test-equal "jail build config exposes minimal PATH"
|
|
"/bin:/sbin:/usr/bin:/usr/sbin:/usr/local/bin"
|
|
(and path-entry (cdr path-entry)))
|
|
(test-equal "jail build config sets TMPDIR"
|
|
"/tmp"
|
|
(and tmpdir-entry (cdr tmpdir-entry))))
|
|
|
|
(let* ((command (build-jail-command-string
|
|
(jail-native-build-executor)
|
|
"/tmp/fruix-jail-root"
|
|
"fruix-test"
|
|
(build-jail-base-config (jail-native-build-executor))
|
|
"/run.sh"))
|
|
(networked-command (build-jail-command-string
|
|
(jail-native-build-executor #:network? #t)
|
|
"/tmp/fruix-jail-root"
|
|
"fruix-test"
|
|
(build-jail-base-config (jail-native-build-executor #:network? #t))
|
|
"/run.sh")))
|
|
(test-assert "jail command disables IPv4 and IPv6 by default"
|
|
(and (string-contains command " ip4=disable")
|
|
(string-contains command " ip6=disable")))
|
|
(test-assert "jail command can opt into network access"
|
|
(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"))
|
|
(result-file (string-append output-dir "/result"))
|
|
(user-file (string-append output-dir "/user"))
|
|
(env-file (string-append output-dir "/env"))
|
|
(pwd-file (string-append output-dir "/pwd"))
|
|
(config (build-jail-config
|
|
#:name "fruix-build-jails-copy"
|
|
#: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"))))
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(setenv "FRUIX_BUILD_JAIL_TEST_SECRET" "should-not-leak"))
|
|
(lambda ()
|
|
(run-script-in-temporary-jail
|
|
executor
|
|
(string-append "#!/bin/sh\n"
|
|
"set -eu\n"
|
|
"printf ok > /out/result\n"
|
|
"id -un > /out/user\n"
|
|
"env | sort > /out/env\n"
|
|
"pwd > /out/pwd\n")
|
|
#:config config))
|
|
(lambda ()
|
|
(unsetenv "FRUIX_BUILD_JAIL_TEST_SECRET")))
|
|
(test-equal "generic jail runner writes result"
|
|
"ok"
|
|
(trim (command-output "cat" result-file)))
|
|
(test-equal "generic jail runner uses current user ownership context"
|
|
(trim (command-output "id" "-un"))
|
|
(trim (command-output "cat" user-file)))
|
|
(test-equal "generic jail runner uses configured workdir"
|
|
"/out"
|
|
(trim (command-output "cat" pwd-file)))
|
|
(let ((env-text (command-output "cat" env-file)))
|
|
(test-assert "generic jail runner drops inherited host environment"
|
|
(not (string-contains env-text "FRUIX_BUILD_JAIL_TEST_SECRET=")))
|
|
(test-assert "generic jail runner preserves whitelisted PATH"
|
|
(string-contains env-text "PATH=/bin:/sbin:/usr/bin:/usr/sbin:/usr/local/bin"))
|
|
(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* ((source-a (mktemp-directory "/tmp/fruix-build-jails-union-a.XXXXXX"))
|
|
(source-b (mktemp-directory "/tmp/fruix-build-jails-union-b.XXXXXX"))
|
|
(output-dir (mktemp-directory "/tmp/fruix-build-jails-union-out.XXXXXX"))
|
|
(metadata-file (string-append output-dir "/union-metadata.scm")))
|
|
(mkdir-p (string-append source-a "/bin"))
|
|
(mkdir-p (string-append source-b "/share"))
|
|
(write-file (string-append source-a "/bin/tool") "#!/bin/sh\necho tool\n")
|
|
(write-file (string-append source-b "/share/data") "data\n")
|
|
(materialize-union-tree (list source-a source-b) output-dir
|
|
#:mode 'symlink
|
|
#:metadata-file metadata-file
|
|
#:name "fruix-test-union")
|
|
(test-assert "union tree symlink mode links regular files"
|
|
(let ((target (false-if-exception (readlink (string-append output-dir "/bin/tool")))))
|
|
(and target
|
|
(string=? target (string-append source-a "/bin/tool")))))
|
|
(test-assert "union tree symlink mode links second source"
|
|
(let ((target (false-if-exception (readlink (string-append output-dir "/share/data")))))
|
|
(and target
|
|
(string=? target (string-append source-b "/share/data")))))
|
|
(let* ((metadata (read-scheme-file metadata-file))
|
|
(mode-entry (assoc 'mode metadata))
|
|
(run-metadata-entry (assoc 'run-metadata metadata))
|
|
(run-metadata (and run-metadata-entry (cdr run-metadata-entry)))
|
|
(mounts-entry (and run-metadata (assoc 'mounts run-metadata)))
|
|
(env-entry (and run-metadata (assoc 'env run-metadata)))
|
|
(home-entry (and run-metadata (assoc 'home run-metadata))))
|
|
(test-equal "union tree metadata records symlink mode"
|
|
'symlink
|
|
(and mode-entry (cdr mode-entry)))
|
|
(when run-metadata
|
|
(let ((mounts-text (object->string (and mounts-entry (cdr mounts-entry))))
|
|
(env-text (object->string (and env-entry (cdr env-entry)))))
|
|
(test-assert "union tree jail omits host /etc mount"
|
|
(not (string-contains mounts-text "\"/etc\"")))
|
|
(test-assert "union tree jail omits devfs mount"
|
|
(not (string-contains mounts-text "(devfs")))
|
|
(test-assert "union tree jail uses temporary HOME"
|
|
(and home-entry (string=? (cdr home-entry) "/tmp")))
|
|
(test-assert "union tree jail env overrides HOME to /tmp"
|
|
(string-contains env-text "(\"HOME\" . \"/tmp\")")))))
|
|
(delete-path-if-exists source-a)
|
|
(delete-path-if-exists source-b)
|
|
(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"))
|
|
(common `((source-root . "/usr/src")
|
|
(target . "amd64")
|
|
(target-arch . "amd64")
|
|
(kernconf . "GENERIC")
|
|
(kernconf-path . "/usr/src/sys/amd64/conf/GENERIC")
|
|
(make-flags . ()))))
|
|
(test-assert "native install command disables root-only flags"
|
|
(let ((command (native-install-command-string common build-root "installworld" "/tmp/stage")))
|
|
(and (string-contains command "NO_ROOT=yes")
|
|
(string-contains command "NO_FSCHG=yes"))))
|
|
(run-command/log-with-executor executor common build-root log-file
|
|
"make -C /usr/src -V .CURDIR")
|
|
(test-assert "native build executor can run make with mounted source tree"
|
|
(string-contains (trim (command-output "cat" log-file)) "/usr/src"))
|
|
(when (eq? (native-build-executor-kind executor) 'jail)
|
|
(test-assert "native build executor records jail metadata"
|
|
(file-exists? (string-append log-file ".jail.scm")))))
|
|
|
|
(test-end "build-jails")
|