mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-01-18 21:46:35 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

guix/store/environment.scm: new module

Browse source 
* guix/store/environment.scm
  (<environment>, 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.
This commit is contained in:
Caleb Ristvedt 2019-12-13 10:04:21 -06:00
parent 46e2a65bbf
commit d1832f8b5c
No known key found for this signature in database
GPG key ID: C166AA495F7F189C
3 changed files with 572 additions and 2 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
Makefile.am
View file

@ -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)

79
guix/store/database.scm
View file

@ -36,6 +36,7 @@ (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
@ -46,7 +47,10 @@ (define-module (guix store database)
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 @@ (define (register-derivation-outputs drv)
(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)))))

492
guix/store/environment.scm Normal file
View file

@ -0,0 +1,492 @@
;;; 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 (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-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 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
;; 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 <environment> 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 <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 (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 <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 #: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)))