Run native build steps in jails
This commit is contained in:
@@ -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
|
||||
|
||||
@@ -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")
|
||||
Executable
+15
@@ -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"
|
||||
Reference in New Issue
Block a user