diff --git a/modules/fruix/system/freebsd/build.scm b/modules/fruix/system/freebsd/build.scm index f4a3294..4ce5020 100644 --- a/modules/fruix/system/freebsd/build.scm +++ b/modules/fruix/system/freebsd/build.scm @@ -195,6 +195,135 @@ (unless (zero? status) (error (format #f "command failed; see ~a: ~a" log-file command))))) +(define (command-success? program . args) + (zero? (apply system* program args))) + +(define (shell-quote text) + (string-append "'" (string-replace-all text "'" "'\"'\"'") "'")) + +(define (copy-build-jail-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-gid-string) + (or (safe-command-output "id" "-g") + "0")) + +(define (default-copy-build-executor) + (if (copy-build-jail-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 copy-build-mounted-host-paths + '("/bin" + "/sbin" + "/lib" + "/libexec" + "/usr/bin" + "/usr/include" + "/usr/lib" + "/usr/libdata" + "/usr/share" + "/usr/src" + "/usr/local" + "/etc")) + +(define (copy-plan-entry-script entry) + (match entry + (('file source target) + (let ((destination (string-append "/out/" target))) + (string-append + "mkdir -p " (shell-quote (dirname destination)) "\n" + "if [ -L " (shell-quote source) " ]; then\n" + " ln -sfn \"$(readlink " (shell-quote source) ")\" " (shell-quote destination) "\n" + "else\n" + " install -m \"$(stat -f %Lp " (shell-quote source) ")\" " + (shell-quote source) " " (shell-quote destination) "\n" + "fi\n"))) + (('directory source target) + (let ((destination (string-append "/out/" target))) + (string-append + "mkdir -p " (shell-quote destination) "\n" + "(cd " (shell-quote source) " && tar -cpf - .) | (cd " (shell-quote destination) " && tar -xpf -)\n"))) + (_ + (error (format #f "unsupported install plan entry: ~s" entry))))) + +(define (copy-build-jail-script package) + (string-append + "#!/bin/sh\n" + "set -eu\n" + (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 (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)) + (else + (for-each (lambda (entry) + (materialize-plan-entry output-path entry)) + (freebsd-package-install-plan package)))) + (write-file (string-append output-path "/.fruix-build-info.scm") + (object->string `((executor . ,executor) + (package . ,(freebsd-package-name package)) + (version . ,(freebsd-package-version package)))))) + (write-file (string-append output-path "/.references") + (string-join input-paths "\n")) + (write-file (string-append output-path "/.fruix-package") manifest) + output-path) + (define (ensure-native-build-root common build-root) (mkdir-p build-root) (mkdir-p (string-append build-root "/logs")) @@ -384,13 +513,10 @@ (unless (file-exists? output-path) (case (freebsd-package-build-system prepared-package) ((copy-build-system) - (mkdir-p output-path) - (for-each (lambda (entry) - (materialize-plan-entry output-path entry)) - (freebsd-package-install-plan prepared-package)) - (write-file (string-append output-path "/.references") - (string-join effective-input-paths "\n")) - (write-file (string-append output-path "/.fruix-package") manifest)) + (materialize-copy-freebsd-package prepared-package + effective-input-paths + manifest + output-path)) ((freebsd-world-build-system freebsd-kernel-build-system) (materialize-native-freebsd-package prepared-package effective-input-paths manifest output-path)) (else diff --git a/modules/fruix/system/freebsd/executor.scm b/modules/fruix/system/freebsd/executor.scm index 32c5958..0f24d39 100644 --- a/modules/fruix/system/freebsd/executor.scm +++ b/modules/fruix/system/freebsd/executor.scm @@ -11,6 +11,7 @@ native-build-executor-properties normalize-native-build-executor host-native-build-executor + jail-native-build-executor ssh-guest-native-build-executor self-hosted-native-build-executor)) @@ -93,6 +94,16 @@ `((host-name . ,host-name) (working-directory . ,working-directory))))) +(define* (jail-native-build-executor #:key (name "jail") + host-name root-directory sudo-command) + (native-build-executor + #:kind 'jail + #:name name + #:properties (filter-map identity + `((host-name . ,host-name) + (root-directory . ,root-directory) + (sudo-command . ,sudo-command))))) + (define* (ssh-guest-native-build-executor #:key (name "ssh-guest") transport orchestrator guest-host-name guest-ip vm-id vdi-id) diff --git a/tests/package-cli.scm b/tests/package-cli.scm index a0eac02..8f91b03 100644 --- a/tests/package-cli.scm +++ b/tests/package-cli.scm @@ -97,6 +97,8 @@ (test-assert "package build creates store path" (file-exists? store-path)) (test-assert "package build stages rg binary" - (file-exists? (string-append store-path "/bin/rg")))) + (file-exists? (string-append store-path "/bin/rg"))) + (test-assert "package build writes build info" + (file-exists? (string-append store-path "/.fruix-build-info.scm")))) (test-end "package-cli")