Toggle diff (484 lines)
diff --git a/Makefile.am b/Makefile.am
index 27d76173e5..667f85acc1 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -409,7 +409,8 @@ endif BUILD_DAEMON_OFFLOAD
STORE_MODULES = \
guix/store/database.scm \
guix/store/deduplication.scm \
- guix/store/roots.scm
+ guix/store/roots.scm \
+ guix/store/environment.scm
MODULES += $(STORE_MODULES)
diff --git a/guix/store.scm b/guix/store.scm
index a238cb627a..c3b58090e5 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -192,6 +192,7 @@ (define-module (guix store)
grafting?
%store-prefix
+ compressed-hash
store-path
output-path
fixed-output-path
diff --git a/guix/store/database.scm b/guix/store/database.scm
index 6a9acc2aef..07bd501644 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -38,6 +38,8 @@ (define-module (guix store database)
#:use-module (srfi srfi-26)
#:use-module (rnrs io ports)
#:use-module (ice-9 match)
+ #:use-module (ice-9 vlist)
+ #:use-module (system foreign)
#:export (sql-schema
%default-database-file
store-database-file
@@ -52,7 +54,10 @@ (define-module (guix store database)
registered-derivation-outputs
%epoch
reset-timestamps
- vacuum-database))
+ vacuum-database
+ outputs-exist?
+ file-closure
+ all-transitive-inputs))
;;; Code for working with the store database directly.
@@ -441,3 +446,84 @@ (define (vacuum-database)
(let ((db (sqlite-open (store-database-file))))
(sqlite-exec db "VACUUM;")
(sqlite-close db)))
+
+(define (outputs-exist? db drv-path outputs)
+ "Determine whether all output labels in OUTPUTS exist as built outputs of
+DRV-PATH."
+ (let ((statement
+ (sqlite-prepare
+ db
+ "
+SELECT id
+FROM ValidPaths
+WHERE path IN (
+ SELECT path
+ FROM DerivationOutputs
+ WHERE DerivationOutputs.id = :id
+ AND drv IN (
+ SELECT id FROM ValidPaths WHERE path = :drvpath
+ )
+)"
+ #:cache? #t)))
+ (sqlite-bind-arguments statement #:drvpath drv-path)
+
+ (every (lambda (out-id)
+ (sqlite-bind-arguments statement #:id out-id)
+ (sqlite-step-and-reset statement))
+ outputs)))
+
+(define* (file-closure db path #:key (list-so-far vlist-null))
+ "Return a vlist containing the store paths referenced by PATH, the store
+paths referenced by those paths, and so on."
+ (let ((get-references
+ (sqlite-prepare
+ db
+ "
+SELECT path
+FROM ValidPaths
+WHERE id IN (
+ SELECT reference FROM Refs WHERE referrer IN (
+ SELECT id FROM ValidPaths WHERE path = :path
+ )
+)"
+ #:cache? #t)))
+ ;; to make it possible to go depth-first we need to get all the
+ ;; references of an item first or we'll have re-entrancy issues with
+ ;; the get-references statement.
+ (define (references-of path)
+ ;; There are no problems with resetting an already-reset
+ ;; statement.
+ (sqlite-bind-arguments get-references #:path path)
+ (let ((result
+ (sqlite-fold (lambda (row prev)
+ (cons (vector-ref row 0) prev))
+ '()
+ get-references)))
+ (sqlite-reset get-references)
+ result))
+
+ (let %file-closure ((path path)
+ (references-vlist list-so-far))
+ (if (vhash-assoc path references-vlist)
+ references-vlist
+ (fold %file-closure
+ (vhash-cons path #t references-vlist)
+ (references-of path))))))
+
+(define (all-input-output-paths drv)
+ "Return a list containing the output paths this derivation's inputs need to
+provide."
+ (apply append (map derivation-input-output-paths
+ (derivation-inputs drv))))
+
+(define (all-transitive-inputs db drv)
+ "Produce 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 db 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 0000000000..b088408ef9
--- /dev/null
+++ b/guix/store/environment.scm
@@ -0,0 +1,484 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Caleb Ristvedt <caleb.ristvedt@cune.org>
+;;;
+;;; 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 (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-proc
+ 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-proc) ; 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")
+ (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)
+ (cons '("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 tmpdir name #:optional permissions user group)
+ "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
+ ;; the only guarantee we get from mkdir is that the actual
+ ;; permissions are no more permissive than what we specified. In
+ ;; the event we want to be more permissive than the umask, though,
+ ;; this is necessary.
+ (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 (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 and devpts are already taken care of by run-container
+ `(,@(if (file-exists? "/dev/shm")
+ (list (file-system
+ (device "none")
+ (mount-point "/dev/shm")
+ (type "tmpfs")
+ (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)))
+ (sigaction SIGPIPE SIG_DFL))
+
+
+
+(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 #:key impersonate-linux-2.6?)
+ (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* (make-build-directory drv #:optional uid gid)
+ (let ((build-directory (temp-directory (or (getenv "TMPDIR")
+ "/tmp")
+ (derivation-tempname drv) #o0700
+
