From d1832f8b5cafdccfba99fc615ba932fc69590cf3 Mon Sep 17 00:00:00 2001 From: Caleb Ristvedt Date: Fri, 13 Dec 2019 10:04:21 -0600 Subject: guix/store/environment.scm: new module * guix/store/environment.scm (, environment-{namespaces, variables, temp-dirs, filesystems, new-session?, new-pgroup?, setup-i/o-proc, preserved-fds, chroot, personality, user, group, hostname, 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): new exported variables. * guix/store/database.scm (output-path-id-sql, outputs-exist?, references-sql, file-closure, all-input-output-paths, all-transitive-inputs): new variables. (outputs-exist?, file-closure, all-transitive-inputs): exported. * Makefile.am (STORE_MODULES): add guix/store/environment.scm. --- Makefile.am | 3 +- guix/store/database.scm | 79 +++++++- guix/store/environment.scm | 492 +++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 572 insertions(+), 2 deletions(-) create mode 100644 guix/store/environment.scm diff --git a/Makefile.am b/Makefile.am index 0bce8ac9f1..43a98ad906 100644 --- a/Makefile.am +++ b/Makefile.am @@ -311,7 +311,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/database.scm b/guix/store/database.scm index 22f411597a..a659dea1cf 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -36,6 +36,7 @@ #: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 @@ -46,7 +47,10 @@ register-items registered-derivation-outputs %epoch - reset-timestamps)) + reset-timestamps + outputs-exist? + file-closure + all-transitive-inputs)) ;;; Code for working with the store database directly. @@ -403,3 +407,76 @@ it')." (register db item) (report)) items))))))))) + +(define output-path-id-sql + "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))") + +(define* (outputs-exist? drv-path outputs + #:optional (database %default-database-file)) + "Determine whether all output labels in OUTPUTS exist as built outputs of +DRV-PATH." + (with-database database db + (let ((stmt (sqlite-prepare db output-path-id-sql))) + (sqlite-bind-arguments stmt #:drvpath drv-path) + (let ((result (every (lambda (out-id) + (sqlite-reset stmt) + (sqlite-bind-arguments stmt #:id out-id) + (sqlite-step stmt)) + outputs))) + (sqlite-finalize stmt) + result)))) + +(define references-sql + "SELECT path FROM ValidPaths WHERE id IN (SELECT reference FROM Refs WHERE +referrer IN (SELECT id FROM ValidPaths WHERE path = :path))") + +(define* (file-closure path #:key + (database %default-database-file) + (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." + (with-database database db + (let ((get-references (sqlite-prepare db references-sql))) + ;; 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-reset get-references) + (sqlite-bind-arguments get-references #:path path) + (sqlite-fold (lambda (row prev) + (cons (vector-ref row 0) prev)) + '() + get-references)) + + (let ((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)))))) + (sqlite-finalize get-references) + result)))) + +(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 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 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..41ce154c16 --- /dev/null +++ b/guix/store/environment.scm @@ -0,0 +1,492 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Caleb Ristvedt +;;; +;;; 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 . + +;;; 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-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 + ;; 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 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 + (($ 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 denoting the bind-mounting of SRC to DEST. Note that +if this is part of a chroot , 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 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 /-." + (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) + (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 (derivation-tempname drv) #o0700 + uid gid))) + ;; XXX: Honor exportReferencesGraph here... + build-directory)) + +(define* (nonchroot-build-environment drv #:key gid uid) + "Create and return an for building DRV outside of a chroot, as +well as the store inputs the build requires." + (let* ((fixed-output? (fixed-output-derivation? drv)) + (build-directory (make-build-directory drv))) + (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 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 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 (make-build-directory drv 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 (derivation-output-path (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 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 #:optional (target-port (current-output-port))) + (if (port-eof? port) + (force-output target-port) + (begin + (put-bytevector target-port (get-bytevector-some port)) + (dump-port port target-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))) + + + -- cgit 1.4.1