Run copy package builds in jails
This commit is contained in:
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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")
|
||||
|
||||
Reference in New Issue
Block a user