[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
06/16: build-derivations: use call-with-container
|
From: |
guix-commits |
|
Subject: |
06/16: build-derivations: use call-with-container |
|
Date: |
Sat, 20 Apr 2019 17:25:28 -0400 (EDT) |
reepca pushed a commit to branch guile-daemon
in repository guix.
commit a25c7840c567744dc6f9e1a56ea516447e7d69ff
Author: Caleb Ristvedt <address@hidden>
Date: Wed Jan 30 17:30:01 2019 -0600
build-derivations: use call-with-container
* guix/store/build-derivations.scm:
(<build-environment>): new fields filesystems, user, group,
build-dir-inside.
(default-/dev, add-special-filesystems, start-builder-child): replaced to
better accommodate call-with-container.
(mkdir-p*, path-already-assigned?, close-most-files, inputs->mounts): new
procedures.
---
guix/store/build-derivations.scm | 437 +++++++++++++++++----------------------
1 file changed, 186 insertions(+), 251 deletions(-)
diff --git a/guix/store/build-derivations.scm b/guix/store/build-derivations.scm
index 7b3a4d0..d834d89 100644
--- a/guix/store/build-derivations.scm
+++ b/guix/store/build-derivations.scm
@@ -36,6 +36,8 @@
mkdir-p
copy-recursively))
#:use-module (guix build store-copy)
+ #:use-module (gnu system file-systems)
+ #:use-module (gnu build linux-container)
#:use-module (ice-9 textual-ports)
#:use-module (ice-9 match)
#:use-module (rnrs io ports)
@@ -48,13 +50,17 @@
(define-record-type <build-environment>
- (make-build-environment drv chroot-dir build-dir env-vars input-paths)
+ (make-build-environment drv build-dir-inside build-dir env-vars input-paths
+ filesystems user group)
build-environment?
(drv build-environment-derivation) ; <derivation> this is for.
- (chroot-dir build-chroot-dir) ; path of chroot directory.
+ (build-dir-inside build-directory-inside) ; path of chroot directory.
(build-dir build-directory) ; build dir (outside chroot).
(env-vars build-environment-variables) ; alist of environment variables.
- (input-paths build-input-paths)) ; list of paths or pairs of paths.
+ (input-paths build-input-paths) ; list of paths or pairs of paths.
+ (filesystems build-filesystems) ; list of <file-system> objects.
+ (user build-environment-user) ; the user id to build with.
+ (group build-environment-group)) ; the group id to build with.
;;; The derivation building process:
;;; 1. Build inputs if necessary.
@@ -138,27 +144,8 @@
(try-again (+ attempt-number 1))
(throw args))))))
-(define* (parse-delimited str #:optional (delimiter #\space))
- "Returns a list of strings gathered by parsing STR and separating each group
-of characters separated by DELIMITER."
- (let next ((strings '())
- (index (string-skip str delimiter 0)))
- (if index
- (let ((next-index (string-index str delimiter index)))
- (if next-index
- (next (cons (substring str index next-index)
- strings)
- (string-skip str delimiter next-index))
- ;; last thing
- (reverse! (cons (substring str index)
- strings))))
- ;; it's probably expected that this will be parsed
- ;; left-to-right... which it is, but that means the start of the list
- ;; has the rightmost thing. So it should be reversed.
- (reverse! strings))))
-
-
-(define (build-environment-vars drv)
+
+(define (build-environment-vars drv in-chroot-build-dir)
"Returns an alist of environment variable / value pairs for every
environment variable that should be set during the build execution."
(let ((leaked-vars (and
@@ -167,8 +154,7 @@ environment variable that should be set during the build
execution."
(assoc-ref (derivation-builder-environment-vars
drv)
"impureEnvVars")))
(and leak-string
- (parse-delimited leak-string)))))
- (in-chroot-build-dir (build-directory-name drv 0 "/tmp")))
+ (parse-delimited leak-string))))))
(append `(("PATH" . "/path-not-set")
("HOME" . "/homeless-shelter")
("NIX_STORE" . ,%store-directory)
@@ -183,8 +169,7 @@ environment variable that should be set during the build
execution."
("TEMPDIR" . ,in-chroot-build-dir)
("TMP" . ,in-chroot-build-dir)
("TEMP" . ,in-chroot-build-dir)
- ("PWD" . ,in-chroot-build-dir)
- ("GUILE_AUTO_COMPILE" . "0"))
+ ("PWD" . ,in-chroot-build-dir))
(if (fixed-output-derivation? drv)
'(("NIX_OUTPUT_CHECKED" . "1"))
'())
@@ -193,31 +178,20 @@ environment variable that should be set during the build
execution."
(cons leaked-var (getenv leaked-var)))
leaked-vars)
'())
- (map (match-lambda
- ((outid . output)
- (cons outid (derivation-output-path output))))
- (derivation-outputs drv))
(derivation-builder-environment-vars drv))))
-(define (default-/dev chroot-dir)
- "Sets up the default /dev environment in CHROOT-DIR and returns the
-files/directories from the host /dev that should be in the chroot."
- (define (in-chroot file-name)
- (string-append chroot-dir file-name))
- (mkdir (in-chroot "/dev"))
- (symlink "/proc/self/fd" (in-chroot "/dev/fd"))
- (symlink "/proc/self/fd/0" (in-chroot "/dev/stdin"))
- (symlink "/proc/self/fd/1" (in-chroot "/dev/stdout"))
- (symlink "/proc/self/fd/2" (in-chroot "/dev/stderr"))
- (append '("/dev/full"
- "/dev/null"
- "/dev/random"
- "/dev/tty"
- "/dev/urandom"
- "/dev/zero")
- (if (file-exists? "/dev/kvm")
- '("/dev/kvm")
- '())))
+(define (default-files drv)
+ "Returns a list of the files to be bind-mounted that aren't store items or
+already added by call-with-container."
+ `(,@(if (file-exists? "/dev/kvm")
+ '("/dev/kvm")
+ '())
+ ,@(if (fixed-output-derivation? drv)
+ '("/etc/resolv.conf"
+ "/etc/nsswitch.conf"
+ "/etc/services"
+ "/etc/hosts")
+ '())))
;; yes, there is most likely already something that does this.
(define (format-file file-name . args)
@@ -225,82 +199,73 @@ files/directories from the host /dev that should be in
the chroot."
(lambda (port)
(apply simple-format port args))))
-(define* (mkdir-new dir-name #:optional mode)
- (when (file-exists? dir-name)
- (delete-file-recursively dir-name))
- (if mode
- (mkdir dir-name mode)
- (mkdir dir-name)))
+(define* (mkdir-p* dir #:optional permissions)
+ (mkdir-p dir)
+ (when permissions
+ (chmod dir permissions)))
-(define (add-core-files chroot-dir drv)
+(define (add-core-files environment)
"Creates core files that will not vary when the derivation is constant. That
is, whether these files are present or not is influenced solely by the
derivation itself."
- (define (in-chroot file-name)
- (string-append chroot-dir file-name))
-
- (mkdir-new chroot-dir #o0750)
- (mkdir-p (in-chroot %store-directory))
- (chmod (in-chroot %store-directory) #o1775)
- (mkdir (in-chroot "/tmp") #o1777)
- (mkdir (in-chroot "/etc"))
-
- ;; The output can be a file or a directory (!) so let the builder pick
- ;; whatever it wants and then just copy the thing to the real store after.
- ;; (for-each (lambda (output-pair)
- ;; (mkdir-new (derivation-output-path (cdr output-pair))))
- ;; (derivation-outputs drv))
- (format-file (in-chroot "/etc/passwd")
- (string-append "nixblkd:x:~a:~a:Nix build user:/:/noshell~%"
- "nobody:x:65535:65534:Nobody:/:/noshell~%")
- (getuid)
- (getgid))
- (format-file (in-chroot "/etc/group")
+ (mkdir-p* %store-directory #o1775)
+ (mkdir-p* "/tmp" #o1777)
+ (mkdir-p* "/etc")
+
+ (format-file "/etc/passwd"
+ (string-append "nixbld:x:~a:~a:Nix build user:/:/noshell~%"
+ "nobody:x:65534:65534:Nobody:/:/noshell~%")
+ (build-environment-user environment)
+ (build-environment-group environment))
+ (format-file "/etc/group"
"nixbld:!:~a:~%"
- (getgid))
- (unless (fixed-output-derivation? drv)
- (format-file (in-chroot "/etc/hosts")
- "127.0.0.1 localhost~%")))
+ (build-environment-group environment))
+ (unless (fixed-output-derivation?
+ (build-environment-derivation environment))
+ (format-file "/etc/hosts" "127.0.0.1 localhost~%")))
+
+(define (path-already-assigned? path paths)
+ "Determines whether something is already going to be bind-mounted to PATH
+based on what is in PATHS, which should be a list of paths or path pairs."
+ (find (match-lambda
+ ((source . target)
+ (string= target path))
+ (target
+ (string= target path)))
+ paths))
(define* (prepare-build-environment drv #:key
build-chroot-dirs
- (extra-chroot-dirs '()))
+ (extra-chroot-dirs '())
+ (build-user (getuid))
+ (build-group (getgid)))
"Creates a <build-environment> for the derivation DRV. BUILD-CHROOT-DIRS
will override the default chroot directories, EXTRA-CHROOT-DIRS will
-not. Those two arguments should be lists of either file names or pairs of file
-names of the form (outside . inside). Returns the <build-environment> and a
-list of all the files to be added from the store (useful for scanning for
-references to them)."
+not. Those two arguments should be #f or lists of either file names or pairs
+of file names of the form (outside . inside). Returns the <build-environment>
+and a list of all the files to be added from the store (useful for scanning
+for references to them)."
(let* ((build-dir (make-build-directory drv))
- (build-chroot (string-append (derivation-file-name drv) ".chroot"))
- (env-vars (build-environment-vars drv))
- (additional-files (append (or build-chroot-dirs
- %default-chroot-dirs)
- extra-chroot-dirs
- (if (fixed-output-derivation? drv)
- '("/etc/resolv.conf"
- "/etc/nsswitch.conf"
- "/etc/services"
- "/etc/hosts")
- '())))
- (inputs-from-store (all-transitive-inputs drv)))
- (define (in-chroot file)
- (string-append build-chroot file))
+ (build-dir-inside (build-directory-name drv 0 "/tmp"))
+ (env-vars (build-environment-vars drv build-dir-inside))
+ (inputs-from-store (all-transitive-inputs drv))
+ (all-inputs `(,@(or build-chroot-dirs
+ %default-chroot-dirs)
+ ,@extra-chroot-dirs
+ ,@(default-files drv)
+ ,(cons build-dir
+ build-dir-inside)
+ ,@inputs-from-store
+ ,@(derivation-sources drv))))
;; 4. Honor "environment variables" passed through the derivation.
;; these include "impureEnvVars", "exportReferencesGraph",
;; "build-chroot-dirs", "build-extra-chroot-dirs", "preferLocalBuild"
-
- (add-core-files build-chroot drv)
(values
- (make-build-environment drv build-chroot build-dir env-vars
- `(,@(if (member "/dev" additional-files)
- '()
- (default-/dev build-chroot))
- ,(cons build-dir
- (build-directory-name drv 0 "/tmp"))
- ,@inputs-from-store
- ,@(derivation-sources drv)
- ,@additional-files))
+ (make-build-environment drv build-dir-inside build-dir env-vars
+ all-inputs
+ (special-filesystems all-inputs)
+ build-user
+ build-group)
inputs-from-store)))
(define (all-transitive-inputs drv)
@@ -340,59 +305,31 @@ code points."
(()
(list->string (reverse! result-list))))))
-(define (current-mounts)
- "Returns a list of mounts obtained by reading /proc/self/mountinfo"
- (call-with-input-file "/proc/self/mountinfo"
- (lambda (mountinfo)
- (let next-mount ((mounts '()))
- (if (port-eof? mountinfo)
- mounts
- (next-mount (cons (octal-escaped
- (list-ref (parse-delimited
- (read-line mountinfo))
- 4))
- mounts)))))))
-
-(define (make-current-mounts-private)
- "Makes all mounts in the current process's namespace be of MS_PRIVATE
-propagation type."
- (for-each (lambda (some-mount)
- (mount "none" some-mount "none" MS_PRIVATE))
- (current-mounts)))
-
-
-(define (touch file)
- (call-with-output-file file noop))
-
-(define (bind-mount from to)
- (unless (file-exists? to)
- (if (file-is-directory? from)
- (mkdir-p to)
- (touch to)))
- (mount from to "none" MS_BIND))
-
-(define (add-special-filesystems environment)
- (define (in-chroot file)
- (string-append (build-chroot-dir environment) file))
-
- (when (file-exists? "/dev/shm")
- (mkdir-p (in-chroot "/dev/shm"))
- (mount "none" (in-chroot "/dev/shm") "tmpfs"))
-
- (mkdir-p (in-chroot "/proc"))
- (mount "none" (in-chroot "/proc") "proc")
-
- ;; Indicates CONFIG_DEVPTS_MULTIPLE_INSTANCES=y in the kernel.
- (when (and (file-exists? "/dev/pts/ptmx")
- (not (file-exists?
- (in-chroot "/dev/ptmx")))
- (not (member "/dev/pts"
- (build-input-paths environment))))
- (mkdir-p (in-chroot "/dev/pts"))
- (mount "none" (in-chroot "/dev/pts") "devpts"
- 0 "newinstance,mode=0620")
- (symlink "/dev/pts/ptmx" (in-chroot "/dev/ptmx"))
- (chmod (in-chroot "/dev/pts/ptmx") #o0666)))
+(define (special-filesystems input-paths)
+ "Returns whatever new filesystems need to be created in the container, which
+depends on whether they're already set to be bind-mounted. INPUT-PATHS must be
+a list of paths or pairs of paths."
+ ;; procfs is already taken care of by call-with-container
+ `(,@(if (file-exists? "/dev/shm")
+ (list (file-system
+ (device "none")
+ (mount-point "/dev/shm")
+ (type "tmpfs")
+ (check? #f)))
+ '())
+
+ ;; Indicates CONFIG_DEVPTS_MULTIPLE_INSTANCES=y in the kernel.
+ ,@(if (and (file-exists? "/dev/pts/ptmx")
+ (not (file-exists? "/dev/ptmx"))
+ (not (path-already-assigned? "/dev/pts"
+ input-paths)))
+ (list (file-system
+ (device "none")
+ (mount-point "/dev/pts")
+ (type "devpts")
+ (options "newinstance,mode=0620")
+ (check? #f)))
+ '())))
(define (initialize-loopback)
;; XXX: Implement this. I couldn't find anything in the manual about ioctl,
@@ -407,82 +344,86 @@ environment variables and bind-mounting the listed files.
Importantly, this
assumes that it is in a separate namespace at this point."
;; warning: the order in which a lot of this happens is significant and
;; partially based on guesswork / copying what the c++ does.
- (define (in-chroot file-name)
- (string-append (build-chroot-dir build-environment)
- file-name))
+
+ (add-core-files build-environment)
;; local communication within the build environment should still be
;; possible.
(initialize-loopback)
- (make-current-mounts-private)
- ;; "new_root and put_old must not be on the same filesystem as the current
- ;; root" - man pivot_root(2). This has to happen before special filesystems
- ;; are added.
- (bind-mount (build-chroot-dir build-environment)
- (build-chroot-dir build-environment))
- (environ (map (lambda (env-pair)
- (string-append (car env-pair) "=" (cdr env-pair)))
- (build-environment-variables build-environment)))
- (for-each (match-lambda
- ((outside . inside)
- (bind-mount outside
- (in-chroot inside)))
- (file
- (bind-mount file
- (in-chroot file))))
- (build-input-paths build-environment))
- (add-special-filesystems build-environment))
-
-(define (super-chroot new-root)
- "Whereas a normal chroot makes everything outside a directory invisible,
-this makes it not exist at all! Namespace-local, be careful. If more than one
-process is in this namespace, weird stuff might happen."
- (let ((real-root (string-append new-root "/real-root")))
- (mkdir real-root)
- (pivot-root new-root real-root)
- (chdir "/")
- (umount "real-root" MNT_DETACH)
- (rmdir "real-root")))
-
-(define (start-builder-child environment)
- "Clones the process and sets the child to work building the build described
-by the <build-environment> ENVIRONMENT in a new namespace of many sorts."
- (let* ((drv (build-environment-derivation environment))
- (ret (clone (logior CLONE_NEWPID
- CLONE_NEWNS
- CLONE_NEWIPC
- CLONE_NEWUTS
- (if (fixed-output-derivation? drv)
- 0
- ;CLONE_NEWNET
- 0
- )
- SIGCHLD))))
- (if (= ret 0)
- (catch
- #t
- (lambda ()
- (enact-build-environment environment)
- (super-chroot (build-chroot-dir environment))
- ;; DROP PRIVILEGES HERE
- (chdir (build-directory-name drv 0 "/tmp"))
- (format #t "command line: ~a~%"
- (cons (derivation-builder drv)
- (derivation-builder-arguments drv)))
- (if (zero? (status:exit-val
- (apply execl
- (derivation-builder drv)
- (basename (derivation-builder drv))
- (derivation-builder-arguments drv))))
- (quit 0)
- (throw 'build-failed-but-lets-debug)))
- (lambda (type . args)
- (format #t "Something went wrong in the child...~%")
- (display type)
- (display args)
- (format #t "Here was the top-level directory:~a~%" (scandir "/"))
- (apply throw type args)
- (quit)))
- (status:exit-val (cdr (waitpid ret))))))
+ ;; This couldn't really be described by a <file-system> object, so we have
+ ;; to do this extra bit ourselves.
+ (when (find (lambda (fs)
+ (string=? (file-system-type fs) "devpts"))
+ (build-filesystems build-environment))
+ (symlink "/dev/pts/ptmx" "/dev/ptmx")
+ (chmod "/dev/pts/ptmx" #o0666))
+ (environ (map (match-lambda
+ ((key . val)
+ (string-append key "=" val)))
+ (build-environment-variables build-environment))))
+
+;; The C++ stuff does this, and in pursuit of a bug I will mindlessly mimic
+;; anything.
+(define (close-most-files)
+ (port-for-each (lambda (port)
+ (when (port-filename port)
+ (let ((port-fd (port->fdes port)))
+ (unless (or
+ (= port-fd (port->fdes (current-input-port)))
+ (= port-fd (port->fdes (current-output-port)))
+ (= port-fd (port->fdes (current-error-port))))
+ (close port-fd)))))))
+
+(define (inputs->mounts inputs)
+ (map (match-lambda
+ ((source . dest)
+ (file-system
+ (device source)
+ (mount-point dest)
+ (type "none")
+ (flags '(bind-mount))
+ (check? #f)))
+ (source
+ (file-system
+ (device source)
+ (mount-point source)
+ (type "none")
+ (flags '(bind-mount))
+ (check? #f))))
+ inputs))
+
+(define (run-builder environment)
+ "Runs the builder in the environment ENVIRONMENT."
+ (let ((drv (build-environment-derivation environment)))
+ (call-with-container
+ (append (inputs->mounts (build-input-paths environment))
+ (build-filesystems environment))
+ (lambda ()
+ (enact-build-environment environment)
+ ;(close-most-files)
+ ;; DROP PRIVILEGES HERE
+ (chdir (build-directory-inside environment))
+
+ (format #t "command line: ~a~%"
+ (cons (derivation-builder drv)
+ (derivation-builder-arguments drv)))
+ (if (zero? (status:exit-val
+ (apply system*
+ (derivation-builder drv)
+ ;(basename (derivation-builder drv))
+ (derivation-builder-arguments drv))))
+ 0
+ (throw 'build-failed-but-lets-debug drv)))
+ #:namespaces `(mnt pid ipc uts ,@(if (fixed-output-derivation? drv)
+ '(net)
+ '()))
+ #:host-uids (1+ (build-environment-user environment))
+ #:use-output (lambda (root)
+ (for-each (match-lambda
+ ((outid . ($ <derivation-output> output-path))
+ (copy-recursively (string-append root
+ output-path)
+ output-path)))
+ (derivation-outputs drv))))))
;; I want to be able to test if a derivation's outputs exist without reading
;; it in. The database makes this possible. But we can't figure out WHICH
@@ -770,26 +711,20 @@ such order exists."
(values result visited))))))
(define (do-derivation-build drv)
- (ensure-input-outputs-exist (derivation-inputs drv))
(format #t "Starting build of derivation ~a~%~%" drv)
;; inputs should all exist as of now
- (let-values (((build-env store-inputs) (prepare-build-environment drv)))
- (define (in-chroot file)
- (string-append (build-chroot-dir build-env) file))
-
- (if (zero? (start-builder-child build-env))
- (begin
- (for-each (match-lambda
- ((outid . ($ <derivation-output> output-path))
- (copy-recursively (in-chroot output-path)
- output-path)))
- (derivation-outputs drv))
- (get-output-specs drv store-inputs))
+ (let-values (((build-env store-inputs)
+ (prepare-build-environment drv #:extra-chroot-dirs '())))
+ (if (zero? (run-builder build-env))
+ (get-output-specs drv store-inputs)
#f)))
(define (%build-derivation drv)
"Given a <derivation> DRV, builds/substitutes the derivation unconditionally
even if its outputs already exist."
+ ;; Inputs need to exist regardless of how we're getting the outputs of this
+ ;; derivation.
+ (ensure-input-outputs-exist (derivation-inputs drv))
(let ((output-specs
(or (attempt-substitute drv)
(maybe-use-builtin drv)
- 03/16: guix: store: Register derivation outputs., (continued)
- 03/16: guix: store: Register derivation outputs., guix-commits, 2019/04/20
- 08/16: linux-container: don't include /dev/ptmx or /dev/pts from host., guix-commits, 2019/04/20
- 11/16: syscalls: add missing pieces for derivation build environment, guix-commits, 2019/04/20
- 10/16: gnu: linux-container: Make it more suitable for derivation-building., guix-commits, 2019/04/20
- 04/16: guix/store/build-derivations.scm: new module., guix-commits, 2019/04/20
- 05/16: linux-container: new use-output argument., guix-commits, 2019/04/20
- 12/16: config: add variables for more directories, %impersonate-linux-2.6?, guix-commits, 2019/04/20
- 14/16: build-derivations: scan for hashes, not full paths., guix-commits, 2019/04/20
- 13/16: derivations: migrate the rest of the non-rpc-related bindings., guix-commits, 2019/04/20
- 01/16: gnu: address@hidden: Honor NIX_STORE., guix-commits, 2019/04/20
- 06/16: build-derivations: use call-with-container,
guix-commits <=
- 09/16: build-derivations: Leaked environment variables more robust., guix-commits, 2019/04/20
- 15/16: build-derivations: Adapt docstrings to fit style., guix-commits, 2019/04/20
- 07/16: build-derivations: initial build-group support, guix-commits, 2019/04/20
- 02/16: guix: split (guix store) and (guix derivations)., guix-commits, 2019/04/20
- 16/16: build-derivations: move environment code to (guix store environment), guix-commits, 2019/04/20