[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
16/16: build-derivations: move environment code to (guix store environme
|
From: |
guix-commits |
|
Subject: |
16/16: build-derivations: move environment code to (guix store environment) |
|
Date: |
Sat, 20 Apr 2019 17:25:30 -0400 (EDT) |
reepca pushed a commit to branch guile-daemon
in repository guix.
commit b1ff58038ec310cd890e29807a4ab4133db53c8b
Author: Caleb Ristvedt <address@hidden>
Date: Sat Apr 20 02:24:25 2019 -0500
build-derivations: move environment code to (guix store environment)
Code for handling environments has been moved from (guix store
build-derivations) to (guix store environment), along with some basic useful
environments - namely, the various build environments that can be used.
* guix/store/build-derivations.scm (<build-environment>, build-environment?,
etc): replaced by <environment> and such in (guix store environment).
(builtin-download): now does a proper exec of download script.
(all-input-output-paths, all-transitive-inputs): moved to (guix store
database).
(build-directory-name, prepare-build-environment,
disable-address-randomization, setup-i/o, open-builder-pipe,
attempt-substitute?): Removed.
(build-environment-vars, default-files, format-file, mkdir-p*,
add-core-files, path-already-assigned?, special-filesystems,
inputs->mounts,
dump-port, %default-chroot-dirs): moved to (guix store environment).
(%keep-build-dir?): new variable
(get-build-user, get-build-group, copy-outputs,
builder+environment+inputs):
new procedures.
(%build-derivation, run-builder): adjusted to use <environment> from (guix
store environment).
* guix/store/database.scm (all-input-output-paths, all-transitive-inputs):
new
procedures.
* guix/store/environment.scm: new module.
(build-environment-vars, default-files, format-file, mkdir-p*,
add-core-files, path-already-assigned?, special-filesystems, input->mount,
dump-port): procedures moved from (guix store build-derivations).
(<environment>): new record type.
(%standard-preserved-fds): new variable.
(delete-environment, run-in-environment, bind-mount, temp-directory,
standard-i/o-setup, derivation-tempname, default-personality,
nonchroot-build-environment, builtin-builder-environment,
chroot-build-environment, redirected-path, redirect-outputs, run-standard,
wait-for-build): new procedures.
* Makefile.am: add guix/store/environment.scm to STORE_MODULES.
---
Makefile.am | 3 +-
guix/store/build-derivations.scm | 564 ++++++++-------------------------------
guix/store/database.scm | 24 +-
guix/store/environment.scm | 508 +++++++++++++++++++++++++++++++++++
4 files changed, 639 insertions(+), 460 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 1fbbaa9..8eb1292 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -285,7 +285,8 @@ STORE_MODULES = \
guix/store/database.scm \
guix/store/deduplication.scm \
guix/store/roots.scm \
- guix/store/build-derivations.scm
+ guix/store/build-derivations.scm \
+ guix/store/environment.scm
MODULES += $(STORE_MODULES)
diff --git a/guix/store/build-derivations.scm b/guix/store/build-derivations.scm
index 6fdd7b4..6b3dbf8 100644
--- a/guix/store/build-derivations.scm
+++ b/guix/store/build-derivations.scm
@@ -39,7 +39,6 @@
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,37 +47,9 @@
#:use-module (ice-9 q)
#:use-module (srfi srfi-43)
#:use-module (rnrs bytevectors)
+ #:use-module (guix store environment)
#:export (build-derivation))
-
-(define-record-type <build-environment>
- (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.
- (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.
- (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.
-;;; 2. Make a build directory under TMPDIR or /tmp
-;;; 3. Gather all the inputs and sources and anything they transitively
-;;; reference and put them in the store in the chroot directory.
-;;; 4. Make an output directory for the build under /gnu/store in the build
-;;; directory.
-;;; 5. Set all the environment variables listed in the derivation, some of
-;;; which we have to honor ourselves, like "preferLocalBuild",
-;;; "allowSubstitutes", "allowedReferences", "disallowedReferences", and
-;;; "impureEnvVars".
-;;; 6. Run the builder in a chroot where the build directory is the root.
-
-
(define (output-paths drv)
"Return all store output paths produced by DRV."
(match (derivation-outputs drv)
@@ -99,13 +70,20 @@
(store-info output-path (derivation-file-name drv) references))))
(derivation-outputs drv)))
-(define (builtin-download drv)
- ((@@ (guix scripts perform-download) perform-download) drv)
- (get-output-specs drv (all-transitive-inputs drv)))
+(define (builtin-download drv outputs)
+ "Download DRV outputs OUTPUTS into the store."
+ (setenv "NIX_STORE" %store-directory)
+ ;; XXX: Set _NIX_OPTIONS once client settings are known
+ (execl (string-append %libexecdir "/download")
+ "download"
+ (derivation-file-name drv)
+ ;; We assume this has only a single output
+ (derivation-output-path (cdr (first outputs)))))
;; if a derivation builder name is in here, it is a builtin. For normal
;; behavior, make sure everything starts with "builtin:". Also, the procedures
-;; stored in here should take a single argument, the derivation.
+;; stored in here should take two arguments, the derivation and the list of
+;; (output-name . <derivation-output>)s to be built.
(define builtins
(let ((builtins-table (make-hash-table 10)))
@@ -114,395 +92,31 @@
builtin-download)
builtins-table))
-;; We might want to add to this sometime.
-(define %default-chroot-dirs
- '())
-
-(define* (build-directory-name drv #:optional
- (attempt 0)
- (temp-directory %temp-directory))
- (string-append temp-directory
- "/guix-build-"
- (store-path-package-name (derivation-file-name drv))
- "-"
- (number->string attempt)))
-
-(define* (make-build-directory drv #:optional (temp-directory %temp-directory))
- (let try-again ((attempt-number 0))
- (catch 'system-error
- (lambda ()
- (let ((build-dir (build-directory-name drv
- attempt-number
- temp-directory)))
- (mkdir build-dir #o0700)
- build-dir))
- (lambda args
- (if (= (system-error-errno args) EEXIST)
- (try-again (+ attempt-number 1))
- (throw args))))))
-
-
-(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
- (fixed-output-derivation? drv)
- (let ((leak-string
- (assoc-ref (derivation-builder-environment-vars
drv)
- "impureEnvVars")))
- (and leak-string
- (string-tokenize leak-string
- (char-set-complement
- (char-set #\space))))))))
- (append `(("PATH" . "/path-not-set")
- ("HOME" . "/homeless-shelter")
- ("NIX_STORE" . ,%store-directory)
- ;; XXX: make this configurable
- ("NIX_BUILD_CORES" . "0")
- ("NIX_BUILD_TOP" . ,in-chroot-build-dir)
- ;; why yes that is something like /tmp/guix-build-<drv>-0, yes
- ;; indeed it does not make much sense to make that the TMPDIR
- ;; instead of /tmp, and no I do not know why the C++ code does it
- ;; that way.
- ("TMPDIR" . ,in-chroot-build-dir)
- ("TEMPDIR" . ,in-chroot-build-dir)
- ("TMP" . ,in-chroot-build-dir)
- ("TEMP" . ,in-chroot-build-dir)
- ("PWD" . ,in-chroot-build-dir))
- (if (fixed-output-derivation? drv)
- '(("NIX_OUTPUT_CHECKED" . "1"))
- '())
- (if leaked-vars
- ;; leaked vars might not be defined.
- (filter cdr
- (map (lambda (leaked-var)
- (cons leaked-var (getenv leaked-var)))
- leaked-vars))
- '())
- (derivation-builder-environment-vars drv))))
-
-(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)
- (call-with-output-file file-name
- (lambda (port)
- (apply simple-format port args))))
-
-(define* (mkdir-p* dir #:optional permissions)
- (mkdir-p dir)
- (when permissions
- (chmod dir permissions)))
-
-(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."
- (let ((uid (build-environment-user environment))
- (gid (build-environment-group environment)))
- (mkdir-p* %store-directory #o1775)
- (chown %store-directory uid gid)
- (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~%")
- uid gid)
- (format-file "/etc/group"
- "nixbld:!:~a:~%"
- (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 '())
- (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 #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 in the store that could be referenced."
- (let* ((build-dir (make-build-directory drv))
- (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))
- ;; use "or" here instead of having a default value so that passing #f
- ;; works.
- (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))))
- ;;
- ;; TODO: Honor "environment variables" passed through the derivation.
- ;; these include "impureEnvVars", "exportReferencesGraph",
- ;; "allowSubstitutes", "allowedReferences", "disallowedReferences"
- ;; "preferLocalBuild".
- (chown build-dir build-user build-group)
- (values
- (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-input-output-paths drv)
- "Returns a list containing the output paths this derivation's inputs need to
-provide."
- (fold (lambda (input output-paths)
- (append (derivation-input-output-paths input)
- output-paths))
- '()
- (derivation-inputs drv)))
-
-;; Which store items should be included? According to the nix daemon, these
-;; are:
-;; - the relevant outputs of the inputs
-;; - everything referenced (direct/indirect) by the relevant outputs of the
-;; inputs
-;; - the sources
-;; - everything referenced (direct/indirect) by the sources
-;;
-;; Importantly, this doesn't mention recursive inputs. Only direct inputs.
-(define (all-transitive-inputs drv)
- "Produces a list of all inputs and all of their references."
- (let ((input-paths (all-input-output-paths drv)))
- (vhash-fold (lambda (key val prev)
- (cons key prev))
- '()
- (fold (lambda (input list-so-far)
- (file-closure input #:list-so-far list-so-far))
- vlist-null
- `(
- ,@(derivation-sources drv)
- ,@input-paths)))))
-
-(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")
- ;; This check is fishy
- (not (path-already-assigned? "/dev/ptmx"
- input-paths))
- (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 (disable-address-randomization)
- (let ((current-persona (personality #xffffffff)))
- (personality (logior current-persona
- ADDR_NO_RANDOMIZE))))
-
-(define (enact-build-environment build-environment)
- "Makes the <build-environment> BUILD-ENVIRONMENT current by setting the
-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.
- (setsid)
- (add-core-files build-environment)
- ;; local communication within the build environment should still be
- ;; possible.
- (initialize-loopback)
- ;; 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)))
- (sethostname "localhost")
- (disable-address-randomization)
- (setgid (build-environment-group build-environment))
- (setuid (build-environment-user build-environment))
- ;(close-most-files)
- (chdir (build-directory-inside build-environment)))
-
-;; The C++ stuff does this, and in pursuit of a bug I will mindlessly mimic
-;; anything.
-(define (setup-i/o new-output)
- "Redirect output and error streams to LOG-PIPE and get input from
-/dev/null, then close all other FDs."
- ;;
- (redirect-port new-output (current-output-port))
- (redirect-port (current-output-port) (current-error-port))
- (call-with-input-file "/dev/null"
- (lambda (null-port)
- (dup2 (port->fdes null-port) 0)))
- (let close-next ((fd 3))
- ;; XXX: don't hardcode this.
- (when (<= fd 20)
- (false-if-exception (close-fdes fd))
- (close-next (1+ 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 (dump-port port)
- (unless (port-eof? port)
- (display (get-line port))
- (display "\n")
- (dump-port port)))
-
-(define (open-builder-pipe environment)
- (let* ((drv (build-environment-derivation environment))
- (prog (derivation-builder drv))
- (args (derivation-builder-arguments drv)))
- (match (pipe)
- ((read-from . write-to)
- (match (primitive-fork)
- (0
- (close read-from)
- (enact-build-environment environment)
- (setup-i/o write-to)
- (when (stat "/dev/tty")
- (format #t "/dev/tty exists!~%"))
- (apply execl prog (basename prog) args))
- (child-pid
- (close write-to)
- (values read-from child-pid)))))))
-
-(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 ()
- ;(close-most-files)
- (format #t "command line: ~a~%"
- (cons (derivation-builder drv)
- (derivation-builder-arguments drv)))
- (format #t "environment variables: ~a~%" (environ))
-
- (let-values (((read-side pid) (open-builder-pipe environment)))
- (dump-port read-side)
- (close read-side)
- (match (status:exit-val (cdr (waitpid pid)))
- (0
- 0)
- (exit-val
- (throw 'build-failed-but-lets-debug exit-val 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
-;; outputs it even has without reading it in. For most of the derivations, we
-;; don't need to know which outputs it has, as long as we know the outputs we
-;; want. Okay, okay, new plan: build-derivation takes a <derivation>, but
-;; ensure-input-outputs-exist takes <derivation-input>
-;; objects. build-derivation is only called when we know it needs to be built
-
-(define (inputs-closure drv)
- "Given a <derivation> DRV, finds all store paths needed to build it."
- (fold (lambda (input prev)
- (fold (lambda (output outputs-list)
- (cons output outputs-list))
- prev
- (derivation-input-output-paths input)))
- '()
- (derivation-prerequisites drv)))
-
-(define (attempt-substitute drv)
- #f)
-
-(define (maybe-use-builtin drv)
- "Uses a builtin builder to build DRV if it exists. Returns #f if there is no
-builtin builder for DRV or it failed."
- (let ((builder (hash-ref builtins
- (derivation-builder drv))))
- (if builder
- (begin
- ;; strip-store-file-name from (guix build utils), used by
- ;; perform-download indirectly, doesn't honor %store-directory. So
- ;; we have to set it here. ¯\_(ツ)_/¯
- (environ (map (match-lambda
- ((key . val)
- (string-append key "=" val)))
- (build-environment-vars drv "/tmp")))
- (builder drv))
- #f)))
+(define %keep-build-dir? #t)
+
+;; XXX: make this configurable. Maybe I should read some more about those
+;; parameters I've heard about...
+(define %build-group (false-if-exception (group:gid (getgrnam "guixbuild"))))
+(define %build-user-pool (and %build-group
+ (group:mem (getgrgid %build-group))))
+(define (get-build-user)
+ (let ((user (getuid)))
+ (or (and (zero? user)
+ %build-user-pool
+ ;; XXX: When implementing
+ ;; scheduling, make it so this
+ ;; searches for an unused
+ ;; one.
+ (passwd:uid
+ (getpwnam
+ (last %build-user-pool))))
+ user)))
+
+(define (get-build-group)
+ (or (and (zero? (getuid)) %build-group)
+ (getgid)))
(define-record-type <trie-node>
(make-trie-node table string-exists?)
@@ -714,16 +328,19 @@ nar, and the length of the nar."
(force-output scanning-port)
(get-references)))
-;; XXX: make this configurable. Maybe I should read some more about those
-;; parameters I've heard about...
-(define %build-group (false-if-exception (group:gid (getgrnam "guixbuild"))))
-(define %build-user-pool (and %build-group
- (group:mem (getgrgid %build-group))))
+(define (copy-outputs drv environment)
+ "Copy output paths produced in ENVIRONMENT from building DRV to the store if
+a fake store was used."
+ (let ((store-dir (assoc-ref (environment-temp-dirs environment)
+ 'store-directory)))
+ (when store-dir
+ (for-each
+ (match-lambda
+ ((outid . ($ <derivation-output> output-path))
+ (copy-recursively
+ (string-append store-dir "/" (basename output-path)) output-path)))
+ (derivation-outputs drv)))))
-;; every method of getting a derivation's outputs in the store needs to
-;; provide 3 pieces of metadata: the size of the nar, the references of each
-;; output, and the hash of each output. We happen to have ways of getting all
-;; of those as long as we know which references to be looking for.
(define (topologically-sorted store-infos)
"Returns STORE-INFOS in topological order or throws CYCLE-DETECTED if no
such order exists."
@@ -776,44 +393,75 @@ such order exists."
(()
(values result visited))))))
-(define (do-derivation-build drv)
- ;; inputs should all exist as of now
- (let-values (((build-env store-inputs)
- (prepare-build-environment drv
- #:extra-chroot-dirs '()
- #:build-user
- (or (and
- %build-user-pool
- ;; XXX: When implementing
- ;; scheduling, make it so this
- ;; searches for an unused
- ;; one.
- (passwd:uid
- (getpwnam
- (car %build-user-pool))))
- (getuid))
- #:build-group (or %build-group
- (getgid)))))
- (if (zero? (run-builder build-env))
- (get-output-specs drv store-inputs)
- #f)))
-
+(define (run-builder builder drv environment store-inputs)
+ "Run the builder BUILDER for DRV in ENVIRONMENT, wait for it to finish, and
+return the list of <store-info>s corresponding to its outputs."
+ (match (status:exit-val (call-with-values
+ (lambda ()
+ (run-standard environment builder))
+ wait-for-build))
+ (0
+ ;; XXX: check that the output paths were produced.
+ (copy-outputs drv environment)
+ (delete-environment environment)
+ (get-output-specs drv store-inputs))
+ (exit-value
+ (format #t "Builder exited with status ~A~%" exit-value)
+ (if %keep-build-dir?
+ (format #t "Note: keeping build directories: ~A~%"
+ (match (environment-temp-dirs environment)
+ (((sym . dir) ...)
+ dir)))
+ (delete-environment environment))
+ #f)))
+
+(define* (builder+environment+inputs drv #:optional (chroot? #t))
+ "Return a thunk that performs the build action, the environment it should be
+run in, and the store inputs of that environment."
+ (let*-values (((builtin) (hash-ref builtins (derivation-builder drv)))
+ ((environment store-inputs)
+ ((if builtin
+ builtin-builder-environment
+ (if chroot?
+ chroot-build-environment
+ nonchroot-build-environment))
+ drv #:gid (get-build-group) #:uid (get-build-user)))
+ ((builder) (or
+ (and builtin (lambda ()
+ (builtin drv (derivation-outputs
+ drv))))
+ (lambda ()
+ (let ((prog (derivation-builder drv))
+ (args (derivation-builder-arguments drv)))
+ (apply execl prog prog args))))))
+ (values builder environment store-inputs)))
+
+;; Note: used for testing mostly, daemon should be starting builds directly
+;; and not just waiting for them to finish sequentially...
(define (%build-derivation drv)
- "Given a <derivation> DRV, builds/substitutes the derivation unconditionally
-even if its outputs already exist."
+ "Given a <derivation> DRV, build the derivation unconditionally even if its
+outputs already exist."
+ ;; Make sure store permissions and ownership are intact (test-env creates a
+ ;; store with wrong permissions, for example).
+ (when (and (zero? (getuid)) %build-group)
+ (chown %store-directory 0 %build-group)
+ (chmod %store-directory #o1775))
;; Inputs need to exist regardless of how we're getting the outputs of this
;; derivation.
(ensure-input-outputs-exist (derivation-inputs drv))
(format #t "Starting build of derivation ~a~%~%" drv)
- (let ((output-specs
- (or (attempt-substitute drv)
- (maybe-use-builtin drv)
- (do-derivation-build drv))))
+ (let*-values (((builder environment store-inputs)
+ (builder+environment+inputs drv (zero? (getuid))))
+ ((output-specs)
+ (or (attempt-substitute drv)
+ (run-builder builder drv environment store-inputs))))
(if output-specs
(register-items (topologically-sorted output-specs))
(throw 'derivation-build-failed drv))))
(define (ensure-input-outputs-exist inputs)
+ "Call %build-derivation as necessary, recursively, to make the necessary
+outputs of INPUTS exist."
(for-each
(lambda (input)
(let ((input-drv-path (derivation-input-path input)))
diff --git a/guix/store/database.scm b/guix/store/database.scm
index 2098d5d..c264941 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -49,7 +49,8 @@
%epoch
reset-timestamps
outputs-exist?
- file-closure))
+ file-closure
+ all-transitive-inputs))
;;; Code for working with the store database directly.
@@ -465,3 +466,24 @@ paths referenced by those paths, and so on."
(references-of path))))))
(sqlite-finalize get-references)
result))))
+
+(define (all-input-output-paths drv)
+ "Returns a list containing the output paths this derivation's inputs need to
+provide."
+ (fold (lambda (input output-paths)
+ (append (derivation-input-output-paths input)
+ output-paths))
+ '()
+ (derivation-inputs drv)))
+
+(define (all-transitive-inputs drv)
+ "Produces a list of all inputs and all of their references."
+ (let ((input-paths (all-input-output-paths drv)))
+ (vhash-fold (lambda (key val prev)
+ (cons key prev))
+ '()
+ (fold (lambda (input list-so-far)
+ (file-closure input #:list-so-far list-so-far))
+ vlist-null
+ `(,@(derivation-sources drv)
+ ,@input-paths)))))
diff --git a/guix/store/environment.scm b/guix/store/environment.scm
new file mode 100644
index 0000000..400cc4d
--- /dev/null
+++ b/guix/store/environment.scm
@@ -0,0 +1,508 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Caleb Ristvedt <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Code for setting up environments, especially build environments. Builds
+;;; on top of (gnu build linux-container).
+
+(define-module (guix store environment)
+ #:use-module (guix records)
+ #:use-module (guix config)
+ #:use-module (gnu build linux-container)
+ #:use-module (gnu system file-systems)
+ #:use-module ((guix build utils) #:select (delete-file-recursively
+ mkdir-p
+ copy-recursively))
+ #:use-module (guix derivations)
+ #:use-module (guix store)
+ #:use-module (guix build syscalls)
+ #:use-module (guix store database)
+ #:use-module (guix store files)
+ #:use-module (gcrypt hash)
+ #:use-module (guix base32)
+ #:use-module (ice-9 match)
+ #:use-module (rnrs bytevectors)
+ #:use-module (rnrs io ports)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-98)
+
+ #:export (<environment>
+ environment
+ environment-namespaces
+ environment-variables
+ environment-temp-dirs
+ environment-filesystems
+ environment-new-session?
+ environment-new-pgroup?
+ environment-setup-i/o-thunk
+ environment-preserved-fds
+ environment-chroot
+ environment-personality
+ environment-user
+ environment-group
+ environment-hostname
+ environment-domainname
+ build-environment-vars
+ delete-environment
+ run-in-environment
+ bind-mount
+ standard-i/o-setup
+ %standard-preserved-fds
+ nonchroot-build-environment
+ chroot-build-environment
+ builtin-builder-environment
+ run-standard
+ run-standard-build
+ wait-for-build))
+
+(define %standard-preserved-fds '(0 1 2))
+
+(define-record-type* <environment> environment
+ ;; The defaults are set to be as close to the "current environment" as
+ ;; possible.
+ make-environment
+ environment?
+ (namespaces environment-namespaces (default '())) ; list of symbols
+ ; list of (key . val) pairs
+ (variables environment-variables (default (get-environment-variables)))
+ ; list of (symbol . filename) pairs.
+ (temp-dirs environment-temp-dirs (default '()))
+ ;; list of <file-system> objects. Only used when MNT is in NAMESPACES.
+ (filesystems environment-filesystems (default '()))
+ ; boolean (implies NEW-PGROUP?)
+ (new-session? environment-new-session? (default #f))
+ (new-pgroup? environment-new-pgroup? (default #f)) ; boolean
+ (setup-i/o environment-setup-i/o-thunk) ; a thunk or #f
+ ; #f or list of integers (in case of #f, all are preserved)
+ (preserved-fds environment-preserved-fds (default #f))
+ ;; either the chroot directory or #f, must not be #f if MNT is in
+ ;; NAMESPACES! Will be recursively deleted when the environment is
+ ;; destroyed. Ignored if MNT is not in NAMESPACES.
+ (chroot environment-chroot (default #f))
+ (initial-directory environment-initial-directory (default #f)) ; string or #f
+ (personality environment-personality (default #f)) ; integer or #f
+ ;; These are currently naively handled in the case of user namespaces.
+ (user environment-user (default #f)) ; integer or #f
+ (group environment-group (default #f)) ; integer or #f
+ (hostname environment-hostname (default #f)) ; string or #f
+ (domainname environment-domainname (default #f))) ; string or #f
+
+(define (delete-environment env)
+ "Delete all temporary directories used in ENV."
+ (for-each (match-lambda
+ ((id . filename)
+ (delete-file-recursively filename)))
+ (environment-temp-dirs env))
+ (when (environment-chroot env)
+ (delete-file-recursively (environment-chroot env))))
+
+(define (format-file file-name . args)
+ (call-with-output-file file-name
+ (lambda (port)
+ (apply simple-format port args))))
+
+(define* (mkdir-p* dir #:optional permissions)
+ (mkdir-p dir)
+ (when permissions
+ (chmod dir permissions)))
+
+(define (add-core-files environment fixed-output?)
+ "Populate container with miscellaneous files and directories that shouldn't
+be bind-mounted."
+ (let ((uid (environment-user environment))
+ (gid (environment-group environment)))
+ (mkdir-p* "/tmp" #o1777)
+ (mkdir-p* "/etc")
+
+ (unless (or (file-exists? "/etc/passwd")
+ (file-exists? "/etc/group"))
+ (format-file "/etc/passwd"
+ (string-append "nixbld:x:~a:~a:Nix build user:/:/noshell~%"
+ "nobody:x:65534:65534:Nobody:/:/noshell~%")
+ uid gid)
+ (format-file "/etc/group" "nixbld:!:~a:~%" gid))
+
+ (unless (or fixed-output? (file-exists? "/etc/hosts"))
+ (format-file "/etc/hosts" "127.0.0.1 localhost~%"))
+ (when (file-exists? "/dev/pts/ptmx")
+ (symlink "/dev/pts/ptmx" "/dev/ptmx")
+ (chmod "/dev/pts/ptmx" #o0666))))
+
+(define (run-in-environment env thunk . i/o-args)
+ "Run THUNK in ENV with I/O-ARGS passed to the SETUP-I/O procedure of
+ENV. Return the pid of the process THUNK is run in."
+ (match env
+ (($ <environment> namespaces variables temp-dirs
+ filesystems new-session? new-pgroup? setup-i/o
+ preserved-fds chroot current-directory new-personality
+ user group hostname domainname)
+ (when (and new-session? (not new-pgroup?))
+ (throw 'invalid-environment "NEW-SESSION? implies NEW-PGROUP?."))
+ (let ((fixed-output? (not (memq 'net namespaces))))
+ (run-container chroot filesystems namespaces (and user (1+ user))
+ (lambda ()
+ (when hostname (sethostname hostname))
+ (when domainname (setdomainname domainname))
+ ;; setsid / setpgrp as necessary
+ (if new-session?
+ (setsid)
+ (when new-pgroup?
+ (setpgid 0 0)))
+ (when chroot
+ (add-core-files env fixed-output?))
+ ;; set environment variables
+ (when variables
+ (environ (map (match-lambda
+ ((key . val)
+ (string-append key "=" val)))
+ variables)))
+ (when setup-i/o (apply setup-i/o i/o-args))
+ ;; set UID and GID
+ (when current-directory (chdir current-directory))
+ (when group (setgid group))
+ (when user (setuid user))
+ ;; Close unpreserved fds
+ (when preserved-fds
+ (let close-next ((n 0))
+ (when (< n 20) ;; XXX: don't hardcode.
+ (unless (memq n preserved-fds)
+ (false-if-exception (close-fdes n)))
+ (close-next (1+ n)))))
+
+ ;; enact personality
+ (when new-personality (personality new-personality))
+ (thunk)))))))
+
+(define (bind-mount src dest)
+ "Return a <file-system> denoting the bind-mounting of SRC to DEST. Note that
+if this is part of a chroot <environment>, DEST will be the name *inside of*
+the chroot, i.e.
+
+(bind-mount \"/foo/x\" \"/bar/x\")
+
+in an environment with chroot \"/chrootdir\" will bind-mount \"/foo/x\" to
+\"/chrootdir/bar/x\"."
+ (file-system
+ (device src)
+ (mount-point dest)
+ (type "none")
+ (flags '(bind-mount))
+ (check? #f)))
+
+(define input->mount
+ (match-lambda
+ ((source . dest)
+ (bind-mount source dest))
+ (source
+ (bind-mount source source))))
+
+(define (default-files drv)
+ "Return 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")
+ '())))
+
+(define (build-environment-vars drv build-dir)
+ "Return an alist of environment variable / value pairs for every environment
+variable that should be set during the build execution."
+ (let ((leaked-vars (and
+ (fixed-output-derivation? drv)
+ (let ((leak-string
+ (assoc-ref (derivation-builder-environment-vars
drv)
+ "impureEnvVars")))
+ (and leak-string
+ (string-tokenize leak-string
+ (char-set-complement
+ (char-set #\space))))))))
+ (append `(("PATH" . "/path-not-set")
+ ("HOME" . "/homeless-shelter")
+ ("NIX_STORE" . ,%store-directory)
+ ;; XXX: make this configurable
+ ("NIX_BUILD_CORES" . "0")
+ ("NIX_BUILD_TOP" . ,build-dir)
+ ("TMPDIR" . ,build-dir)
+ ("TEMPDIR" . ,build-dir)
+ ("TMP" . ,build-dir)
+ ("TEMP" . ,build-dir)
+ ("PWD" . ,build-dir))
+ (if (fixed-output-derivation? drv)
+ '(("NIX_OUTPUT_CHECKED" . "1"))
+ '())
+ (if leaked-vars
+ ;; leaked vars might be #f
+ (filter cdr
+ (map (lambda (leaked-var)
+ (cons leaked-var (getenv leaked-var)))
+ leaked-vars))
+ '())
+ (derivation-builder-environment-vars drv))))
+
+(define* (temp-directory name #:optional permissions user group
+ #:key (tmpdir %temp-directory))
+ "Create a temporary directory under TMPDIR with permissions PERMISSIONS if
+specified, otherwise default permissions as specified by umask, and belonging
+to user USER and group GROUP (defaulting to current user if not specified or
+#f). Return the full filename of the form <tmpdir>/<name>-<number>."
+ (let try-again ((attempt-number 0))
+ (catch 'system-error
+ (lambda ()
+ (let ((attempt-name (string-append tmpdir "/" name "-"
+ (number->string
+ attempt-number 10))))
+ (mkdir attempt-name permissions)
+ (when permissions
+ (chmod attempt-name permissions))
+ ;; -1 means "unchanged"
+ (chown attempt-name (or user -1) (or group -1))
+ attempt-name))
+ (lambda args
+ (if (= (system-error-errno args) EEXIST)
+ (try-again (+ attempt-number 1))
+ (apply throw args))))))
+
+(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 (special-filesystems input-paths)
+ "Return 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")
+ ;; This check is fishy
+ (not (path-already-assigned? "/dev/ptmx"
+ input-paths))
+ (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 (standard-i/o-setup output-port)
+ "Redirect output and error streams to OUTPUT-FD, get input from /dev/null."
+ (define output-fd (port->fdes output-port))
+ (define stdout (fdopen 1 "w"))
+ ;; Useful in case an error happens between here and an exec and it needs to
+ ;; get reported.
+ (set-current-output-port stdout)
+ (set-current-error-port stdout)
+ (dup2 output-fd 1)
+ (dup2 output-fd 2)
+ (call-with-input-file "/dev/null"
+ (lambda (null-port)
+ (dup2 (port->fdes null-port) 0))))
+
+
+
+(define (derivation-tempname drv)
+ (string-append "guix-build-"
+ (store-path-package-name (derivation-file-name drv))))
+
+;; We might want to add to this sometime.
+(define %default-chroot-dirs
+ '())
+
+(define (default-personality drv)
+ (let ((current-personality (personality #xffffffff)))
+ (logior current-personality ADDR_NO_RANDOMIZE
+ (match (cons %system (derivation-system drv))
+ ((or ("x86_64-linux" . "i686-linux")
+ ("aarch64-linux" . "armhf-linux"))
+ PER_LINUX32)
+ (_ 0))
+ (match (cons (derivation-system drv) %impersonate-linux-2.6?)
+ (((or "x86_64-linux" "i686-linux") . #t)
+ UNAME26)
+ (_ 0)))))
+
+(define* (nonchroot-build-environment drv #:key gid uid)
+ "Create and return an <environment> for building DRV outside of a chroot, as
+well as the store inputs the build requires."
+ (let* ((fixed-output? (fixed-output-derivation? drv))
+ (tempname (derivation-tempname drv))
+ (build-directory (temp-directory tempname #o0700)))
+ (values
+ (environment
+ (temp-dirs `((build-directory . ,build-directory)))
+ (initial-directory build-directory)
+ (new-session? #t)
+ (new-pgroup? #t)
+ (variables (build-environment-vars drv build-directory))
+ (preserved-fds %standard-preserved-fds)
+ (setup-i/o standard-i/o-setup)
+ (personality (default-personality drv))
+ (user uid)
+ (group gid))
+ (all-transitive-inputs drv))))
+
+
+(define* (builtin-builder-environment drv #:key gid uid)
+ "Create and return an <environment> for builtin builders, as well as the
+store inputs the build requires."
+ ;; It's just the same as non-chroot-build-environment, but without any
+ ;; environment variables being changed.
+ (let*-values (((env inputs) (nonchroot-build-environment drv
+ #:gid gid
+ #:uid uid)))
+ (values
+ (environment (inherit env)
+ (variables (get-environment-variables)))
+ inputs)))
+
+(define* (chroot-build-environment drv #:key gid uid
+ (extra-chroot-dirs '())
+ build-chroot-dirs )
+ "Create an <environment> for building DRV with standard in-chroot
+settings (as used by nix daemon). Return said environment as well as the
+store paths that are included in it (useful for reference scanning)."
+ (let* ((tempname (derivation-tempname drv))
+ (store-directory (temp-directory (string-append tempname ".store")
+ #o1775 0 gid))
+ (build-directory (temp-directory tempname #o0700 uid gid))
+ (inside-build-dir (string-append %temp-directory "/" tempname "-0"))
+ (fixed-output? (fixed-output-derivation? drv))
+ (store-inputs (all-transitive-inputs drv))
+ (input-paths (append store-inputs
+ (default-files drv)
+ (or build-chroot-dirs
+ %default-chroot-dirs)
+ extra-chroot-dirs)))
+ (values
+ (environment
+ (namespaces `(mnt pid ipc uts ,@(if fixed-output? '() '(net))))
+ (filesystems
+ (cons* (bind-mount build-directory inside-build-dir)
+ (bind-mount store-directory %store-directory)
+ (append (special-filesystems input-paths)
+ (map input->mount input-paths))))
+ (temp-dirs `((store-directory . ,store-directory)
+ (build-directory . ,build-directory)))
+ (initial-directory inside-build-dir)
+ (new-session? #t)
+ (new-pgroup? #t)
+ (setup-i/o (lambda (output-fd)
+ (unless fixed-output?
+ (initialize-loopback))
+ (standard-i/o-setup output-fd)))
+ (variables (build-environment-vars drv inside-build-dir))
+ (preserved-fds %standard-preserved-fds)
+ (chroot (temp-directory (string-append tempname ".chroot") #o750 0 gid))
+ (user uid)
+ (group gid)
+ (personality (default-personality drv))
+ (hostname "localhost")
+ (domainname "(none)"))
+ store-inputs)))
+
+(define (redirected-path drv output)
+ (let* ((original (assoc-ref (derivation-outputs drv) output))
+ (hash
+ (bytevector->nix-base32-string
+ (compressed-hash (sha256 (string-append "rewrite:"
+ (derivation-file-name drv)
+ ":"
+ original))
+ 20))))
+ (string-append (%store-prefix) "/" hash "-"
+ (store-path-package-name original))))
+
+(define (redirect-outputs env drv output-names)
+ "Create a new <environment> based on ENV but modified so that for each
+output-name in OUTPUT-NAMES, the environment variable corresponding to that
+output is set to a newly-generated output path."
+ (environment (inherit env)
+ (variables (append (map (lambda (output)
+ (cons output (redirected-path drv output)))
+ output-names)
+ (remove (lambda (var)
+ (member (car var) output-names))
+ (environment-variables env))))))
+
+(define (run-standard environment thunk)
+ "Run THUNK in ENVIRONMENT. Return the PID it is being run in and the read
+end of the pipe its i/o has been set up with."
+ (match (pipe)
+ ((read . write)
+ (let ((pid (run-in-environment environment
+ (lambda ()
+ (catch #t
+ (lambda ()
+ (thunk)
+ (primitive-exit 0))
+ (lambda args
+ (format #t "Error: ~A~%" args)
+ (primitive-exit 1))))
+ write)))
+ (close-fdes (port->fdes write))
+ (values pid read)))))
+
+(define (run-standard-build drv environment)
+ "Run the builder of DRV in ENVIRONMENT. Return the PID it is being run in
+and the read end of the pipe its i/o has been set up with."
+ (run-standard environment
+ (lambda ()
+ (let ((prog (derivation-builder drv))
+ (args (derivation-builder-arguments drv)))
+ (apply execl prog prog args)))))
+
+(define (dump-port port)
+ (unless (port-eof? port)
+ (put-bytevector (current-output-port)
+ (get-bytevector-some port))
+ (force-output (current-output-port))
+ (dump-port port)))
+
+(define (wait-for-build pid read-port)
+ "Dump all input from READ-PORT to (current-output-port), then wait for PID
+to terminate."
+ (dump-port read-port)
+ (close-fdes (port->fdes read-port))
+ ;; Should we wait specifically for PID to die, or just for any state change?
+ (cdr (waitpid pid)))
+
+
+
- 05/16: linux-container: new use-output argument., (continued)
- 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, 2019/04/20
- 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 <=