diff --git a/modules/fruix/system/freebsd/build.scm b/modules/fruix/system/freebsd/build.scm index 4ce5020..b18d617 100644 --- a/modules/fruix/system/freebsd/build.scm +++ b/modules/fruix/system/freebsd/build.scm @@ -201,25 +201,141 @@ (define (shell-quote text) (string-append "'" (string-replace-all text "'" "'\"'\"'") "'")) -(define (copy-build-jail-available?) +(define (jail-build-available?) (and (file-exists? "/usr/sbin/jail") (file-exists? "/sbin/mount") (command-success? "sudo" "-n" "true"))) -(define (current-uid-string) - (or (safe-command-output "id" "-u") - "0")) +(define (current-user-name) + (safe-command-output "id" "-un")) -(define (current-gid-string) - (or (safe-command-output "id" "-g") - "0")) +(define (current-user-home) + (let ((home (getenv "HOME"))) + (and home + (string-prefix? "/" home) + home))) -(define (default-copy-build-executor) - (if (copy-build-jail-available?) +(define (default-jail-build-executor) + (if (jail-build-available?) (jail-native-build-executor #:host-name (or (safe-command-output "hostname") "localhost") #:sudo-command "sudo -n") (host-native-build-executor #:host-name (or (safe-command-output "hostname") "localhost")))) +(define (default-copy-build-executor) + (default-jail-build-executor)) + +(define (default-native-build-executor) + (default-jail-build-executor)) + +(define (jail-sudo-command executor) + (native-build-executor-ref executor 'sudo-command "sudo -n")) + +(define (jail-nullfs-mount source target mode) + `(nullfs ,source ,target ,mode)) + +(define (jail-devfs-mount target) + `(devfs ,target)) + +(define (path-covered-by-root? path root) + (or (string=? path root) + (string-prefix? (string-append root "/") path))) + +(define (path-covered-by-any-root? path roots) + (any (lambda (root) + (path-covered-by-root? path root)) + roots)) + +(define (jail-root-target jail-root target) + (string-append jail-root target)) + +(define (ensure-jail-mount-target jail-root spec) + (match spec + (('nullfs _ target _) + (mkdir-p (jail-root-target jail-root target))) + (('devfs target) + (mkdir-p (jail-root-target jail-root target))))) + +(define (run-jail-admin-command executor command) + (run-command "sh" "-c" + (string-append (jail-sudo-command executor) + " " + command))) + +(define (mount-jail-spec executor jail-root spec) + (match spec + (('nullfs source target mode) + (let ((mountpoint (jail-root-target jail-root target))) + (run-jail-admin-command + executor + (string-append "mount -t nullfs " + (if (eq? mode 'ro) + "-o ro " + "") + (shell-quote source) + " " + (shell-quote mountpoint))) + mountpoint)) + (('devfs target) + (let ((mountpoint (jail-root-target jail-root target))) + (run-jail-admin-command + executor + (string-append "mount -t devfs devfs " + (shell-quote mountpoint))) + mountpoint)))) + +(define* (run-script-in-temporary-jail executor script + #:key + name + (mounts '()) + (directories '("/tmp"))) + (let* ((jail-root (mktemp-directory "/tmp/fruix-build-jail.XXXXXX")) + (script-path (string-append jail-root "/build.sh")) + (jail-name (string-append (or name "fruix-build") + "-" + (store-hash-string (or name script) #:kind 'jail))) + (jail-user (current-user-name)) + (jail-home (current-user-home)) + (mounted '())) + (dynamic-wind + (lambda () + (for-each (lambda (directory) + (mkdir-p (jail-root-target jail-root directory))) + directories) + (when (and jail-user jail-home) + (mkdir-p (jail-root-target jail-root jail-home))) + (for-each (lambda (spec) + (ensure-jail-mount-target jail-root spec)) + mounts) + (write-file script-path script) + (chmod script-path #o555) + (for-each (lambda (spec) + (set! mounted (cons (mount-jail-spec executor jail-root spec) + mounted))) + mounts)) + (lambda () + (let ((status + (system* "sh" "-c" + (string-append + (jail-sudo-command executor) + " jail -c path=" (shell-quote jail-root) + " name=" (shell-quote jail-name) + " host.hostname=" (shell-quote jail-name) + " exec.clean" + (if jail-user + (string-append " exec.jail_user=" (shell-quote jail-user)) + "") + " command=/bin/sh /build.sh")))) + (unless (zero? status) + (error "jail build command failed" jail-name status)))) + (lambda () + (for-each (lambda (mountpoint) + (false-if-exception + (run-jail-admin-command executor + (string-append "umount " + (shell-quote mountpoint))))) + mounted) + (delete-path-if-exists jail-root))))) + (define copy-build-mounted-host-paths '("/bin" "/sbin" @@ -234,6 +350,40 @@ "/usr/local" "/etc")) +(define native-build-mounted-host-paths + '("/bin" + "/sbin" + "/lib" + "/libexec" + "/usr" + "/frx" + "/etc")) + +(define (copy-build-jail-mounts output-path) + (append (map (lambda (path) + (jail-nullfs-mount path path 'ro)) + (filter file-exists? copy-build-mounted-host-paths)) + (list (jail-devfs-mount "/dev") + (jail-nullfs-mount output-path "/out" 'rw)))) + +(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))) + +(define (native-build-jail-mounts common build-root) + (append (map (lambda (path) + (jail-nullfs-mount path path 'ro)) + (append (filter file-exists? native-build-mounted-host-paths) + (native-build-extra-host-paths common))) + (list (jail-devfs-mount "/dev") + (jail-nullfs-mount build-root build-root 'rw)))) + (define (copy-plan-entry-script entry) (match entry (('file source target) @@ -261,56 +411,43 @@ (string-concatenate (map copy-plan-entry-script (freebsd-package-install-plan package))))) -(define (run-copy-build-in-jail package output-path) - (let* ((jail-root (mktemp-directory "/tmp/fruix-copy-build-jail.XXXXXX")) - (script-path (string-append jail-root "/build.sh")) - (jail-name (string-append "fruix-copy-" (store-hash-string output-path #:kind 'jail))) - (mounts '())) - (dynamic-wind - (lambda () - (for-each (lambda (path) - (mkdir-p (string-append jail-root path))) - copy-build-mounted-host-paths) - (mkdir-p (string-append jail-root "/dev")) - (mkdir-p (string-append jail-root "/tmp")) - (mkdir-p (string-append jail-root "/out")) - (write-file script-path (copy-build-jail-script package)) - (chmod script-path #o555) - (for-each (lambda (path) - (let ((target (string-append jail-root path))) - (run-command "sudo" "-n" "mount" "-t" "nullfs" "-o" "ro" path target) - (set! mounts (cons target mounts)))) - copy-build-mounted-host-paths) - (run-command "sudo" "-n" "mount" "-t" "devfs" "devfs" (string-append jail-root "/dev")) - (set! mounts (cons (string-append jail-root "/dev") mounts)) - (run-command "sudo" "-n" "mount" "-t" "nullfs" output-path (string-append jail-root "/out")) - (set! mounts (cons (string-append jail-root "/out") mounts))) - (lambda () - (let ((status (system* "sh" "-c" - (string-append - "sudo -n jail -c path=" (shell-quote jail-root) - " name=" (shell-quote jail-name) - " host.hostname=" (shell-quote jail-name) - " command=/bin/sh /build.sh")))) - (unless (zero? status) - (error "copy build jail command failed" (freebsd-package-name package) status)))) - (lambda () - (for-each (lambda (mountpoint) - (false-if-exception (run-command "sudo" "-n" "umount" mountpoint))) - mounts) - (false-if-exception (run-command "sudo" "-n" "chown" "-R" - (string-append (current-uid-string) - ":" - (current-gid-string)) - output-path)) - (delete-path-if-exists jail-root))))) +(define (native-command-jail-script command log-file) + (string-append + "#!/bin/sh\n" + "set -eu\n" + "mkdir -p " (shell-quote (dirname log-file)) "\n" + "exec >" (shell-quote log-file) " 2>&1\n" + command + "\n")) + +(define (run-copy-build-in-jail executor package output-path) + (run-script-in-temporary-jail executor + (copy-build-jail-script package) + #:name (string-append "fruix-copy-" + (freebsd-package-name package)) + #:mounts (copy-build-jail-mounts output-path) + #:directories '("/tmp" "/out" "/dev"))) + +(define (run-command/log-with-executor executor common build-root log-file command) + (mkdir-p (dirname log-file)) + (case (native-build-executor-kind executor) + ((jail) + (run-script-in-temporary-jail executor + (native-command-jail-script command log-file) + #:name "fruix-native" + #:mounts (native-build-jail-mounts common build-root) + #:directories '("/tmp" "/dev"))) + (else + (let ((status (system* "sh" "-c" (string-append command " >" log-file " 2>&1")))) + (unless (zero? status) + (error (format #f "command failed; see ~a: ~a" log-file command))))))) (define (materialize-copy-freebsd-package package input-paths manifest output-path) (mkdir-p output-path) (let ((executor (default-copy-build-executor))) (case (native-build-executor-kind executor) ((jail) - (run-copy-build-in-jail package output-path)) + (run-copy-build-in-jail executor package output-path)) (else (for-each (lambda (entry) (materialize-plan-entry output-path entry)) @@ -331,20 +468,22 @@ (write-file (string-append build-root "/build-parameters.scm") (object->string common))) -(define (ensure-native-buildworld common build-root) +(define (ensure-native-buildworld executor common build-root) (let ((stamp (string-append build-root "/stamps/buildworld.done"))) (ensure-native-build-root common build-root) (unless (file-exists? stamp) - (run-command/log (string-append build-root "/logs/buildworld.log") - (make-command-string common build-root "buildworld" #:parallel? #t)) + (run-command/log-with-executor executor common build-root + (string-append build-root "/logs/buildworld.log") + (make-command-string common build-root "buildworld" #:parallel? #t)) (write-file stamp "ok\n")))) -(define (ensure-native-buildkernel common build-root) +(define (ensure-native-buildkernel executor common build-root) (let ((stamp (string-append build-root "/stamps/buildkernel-" (assoc-ref common 'kernconf) ".done"))) - (ensure-native-buildworld common build-root) + (ensure-native-buildworld executor common build-root) (unless (file-exists? stamp) - (run-command/log (string-append build-root "/logs/buildkernel-" (assoc-ref common 'kernconf) ".log") - (make-command-string common build-root "buildkernel" #:parallel? #t)) + (run-command/log-with-executor executor common build-root + (string-append build-root "/logs/buildkernel-" (assoc-ref common 'kernconf) ".log") + (make-command-string common build-root "buildkernel" #:parallel? #t)) (write-file stamp "ok\n")))) (define (prune-stage-paths stage-root paths) @@ -365,9 +504,11 @@ (copy-node source target))) paths) selected-root)) -(define (native-build-output-metadata package common build-root stage-root) + +(define (native-build-output-metadata package executor common build-root stage-root) (let ((plan (freebsd-package-install-plan package))) - `((package . ,(freebsd-package-name package)) + `((executor . ,executor) + (package . ,(freebsd-package-name package)) (version . ,(freebsd-package-version package)) (declared-base . ,(native-build-declared-base plan)) (declared-source . ,(native-build-declared-source plan)) @@ -392,19 +533,21 @@ (define (materialize-native-freebsd-package package input-paths manifest output-path) (let* ((plan (freebsd-package-install-plan package)) (common (native-build-common-manifest plan)) + (executor (default-native-build-executor)) (build-root (native-build-root common)) (stage-root (string-append build-root "/stage-" (freebsd-package-name package) "-" (sha256-string manifest))) (install-log (string-append build-root "/logs/install-" (freebsd-package-name package) ".log")) (final-stage-root (case (freebsd-package-build-system package) ((freebsd-world-build-system) - (ensure-native-buildworld common build-root) + (ensure-native-buildworld executor common build-root) (delete-path-if-exists stage-root) (mkdir-p stage-root) - (run-command/log install-log - (string-append (make-command-string common build-root "installworld" #:destdir stage-root) - " && " - (make-command-string common build-root "distribution" #:destdir stage-root))) + (run-command/log-with-executor executor common build-root + install-log + (string-append (make-command-string common build-root "installworld" #:destdir stage-root) + " && " + (make-command-string common build-root "distribution" #:destdir stage-root))) (let* ((keep-paths (build-plan-ref plan 'keep-paths '())) (selected-root (if (null? keep-paths) stage-root @@ -412,11 +555,12 @@ (prune-stage-paths selected-root (build-plan-ref plan 'prune-paths '())) selected-root)) ((freebsd-kernel-build-system) - (ensure-native-buildkernel common build-root) + (ensure-native-buildkernel executor common build-root) (delete-path-if-exists stage-root) (mkdir-p stage-root) - (run-command/log install-log - (make-command-string common build-root "installkernel" #:destdir stage-root)) + (run-command/log-with-executor executor common build-root + install-log + (make-command-string common build-root "installkernel" #:destdir stage-root)) stage-root) (else (error (format #f "unsupported native FreeBSD build system: ~a" @@ -427,7 +571,7 @@ (string-join input-paths "\n")) (write-file (string-append output-path "/.fruix-package") manifest) (write-file (string-append output-path "/.freebsd-native-build-info.scm") - (object->string (native-build-output-metadata package common build-root final-stage-root))))) + (object->string (native-build-output-metadata package executor common build-root final-stage-root))))) (define (package-with-install-plan package install-plan) (freebsd-package diff --git a/tests/build-jails.scm b/tests/build-jails.scm new file mode 100644 index 0000000..46003a9 --- /dev/null +++ b/tests/build-jails.scm @@ -0,0 +1,75 @@ +(use-modules (srfi srfi-13) + (srfi srfi-64) + (guix build utils) + (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-nullfs-mount + (@@ (fruix system freebsd build) jail-nullfs-mount)) +(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 (trim text) + (string-trim-both text)) + +(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))) + +(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"))) + (run-script-in-temporary-jail + executor + (string-append "#!/bin/sh\n" + "set -eu\n" + "printf ok > /out/result\n" + "id -un > /out/user\n") + #:name "fruix-build-jails-copy" + #:mounts (list (jail-nullfs-mount "/bin" "/bin" 'ro) + (jail-nullfs-mount "/lib" "/lib" 'ro) + (jail-nullfs-mount "/libexec" "/libexec" 'ro) + (jail-nullfs-mount "/usr" "/usr" 'ro) + (jail-nullfs-mount "/etc" "/etc" 'ro) + (jail-devfs-mount "/dev") + (jail-nullfs-mount output-dir "/out" 'rw)) + #:directories '("/tmp" "/dev" "/out")) + (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))))) + +(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") + (kernconf-path . "/usr/src/sys/amd64/conf/GENERIC")))) + (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"))) + +(test-end "build-jails") diff --git a/tests/run-build-jails.sh b/tests/run-build-jails.sh new file mode 100755 index 0000000..b6dfa14 --- /dev/null +++ b/tests/run-build-jails.sh @@ -0,0 +1,15 @@ +#!/bin/sh +set -eu + +repo_root=$(CDPATH= cd -- "$(dirname "$0")/.." && pwd) +. "$HOME/.local/opt/fruix-builder/env.sh" + +guile_version=$($GUILE_BIN -c '(display (effective-version))') +guile_load_path="$repo_root/modules:$GUIX_SOURCE_DIR:$HOME/.local/opt/fruix-builder/shepherd/share/guile/site/$guile_version${GUILE_LOAD_PATH:+:$GUILE_LOAD_PATH}" +guile_load_compiled_path="$HOME/.local/opt/fruix-builder/shepherd/lib/guile/$guile_version/site-ccache${GUILE_LOAD_COMPILED_PATH:+:$GUILE_LOAD_COMPILED_PATH}" + +env \ + GUILE_AUTO_COMPILE=0 \ + GUILE_LOAD_PATH="$guile_load_path" \ + GUILE_LOAD_COMPILED_PATH="$guile_load_compiled_path" \ + "$GUILE_BIN" --no-auto-compile "$repo_root/tests/build-jails.scm"