From patchwork Sun Apr 21 09:42:22 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Christopher Baines X-Patchwork-Id: 63249 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id A7A4427BBEA; Sun, 21 Apr 2024 10:44:31 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, SPF_HELO_PASS,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id E3B2827BBE2 for ; Sun, 21 Apr 2024 10:44:28 +0100 (BST) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1ryTjz-0005ZE-UO; Sun, 21 Apr 2024 05:44:08 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1ryTjo-0005Sm-9W for guix-patches@gnu.org; Sun, 21 Apr 2024 05:43:56 -0400 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1ryTjo-0002pw-0Z; Sun, 21 Apr 2024 05:43:56 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1ryTk0-0006Vm-UH; Sun, 21 Apr 2024 05:44:08 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#70494] [PATCH 04/23] guix: store: environment: New module. Resent-From: Christopher Baines Original-Sender: "Debbugs-submit" Resent-CC: guix@cbaines.net, dev@jpoiret.xyz, ludo@gnu.org, othacehe@gnu.org, rekado@elephly.net, zimon.toutoune@gmail.com, me@tobias.gr, guix-patches@gnu.org Resent-Date: Sun, 21 Apr 2024 09:44:08 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 70494 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 70494@debbugs.gnu.org Cc: Christopher Baines , Christopher Baines , Josselin Poiret , Ludovic =?utf-8?q?Court=C3=A8s?= , Mathieu Othacehe , Ricardo Wurmus , Simon Tournier , Tobias Geerinckx-Rice X-Debbugs-Original-Xcc: Christopher Baines , Josselin Poiret , Ludovic =?utf-8?q?Court=C3=A8s?= , Mathieu Othacehe , Ricardo Wurmus , Simon Tournier , Tobias Geerinckx-Rice Received: via spool by 70494-submit@debbugs.gnu.org id=B70494.171369263224739 (code B ref 70494); Sun, 21 Apr 2024 09:44:08 +0000 Received: (at 70494) by debbugs.gnu.org; 21 Apr 2024 09:43:52 +0000 Received: from localhost ([127.0.0.1]:41785 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ryTje-0006QA-WD for submit@debbugs.gnu.org; Sun, 21 Apr 2024 05:43:51 -0400 Received: from mira.cbaines.net ([2a01:7e00:e000:2f8:fd4d:b5c7:13fb:3d27]:34005) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ryTix-0006Hi-0O for 70494@debbugs.gnu.org; Sun, 21 Apr 2024 05:43:08 -0400 Received: from localhost (unknown [212.132.255.10]) by mira.cbaines.net (Postfix) with ESMTPSA id 477B627BBEB; Sun, 21 Apr 2024 10:42:47 +0100 (BST) Received: from localhost (localhost [local]) by localhost (OpenSMTPD) with ESMTPA id 491aa502; Sun, 21 Apr 2024 09:42:46 +0000 (UTC) From: Christopher Baines Date: Sun, 21 Apr 2024 10:42:22 +0100 Message-ID: X-Mailer: git-send-email 2.41.0 In-Reply-To: <87bk632h36.fsf@cbaines.net> References: <87bk632h36.fsf@cbaines.net> MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches From: Caleb Ristvedt * guix/store/environment.scm: New file. * guix/store.scm: Export compressed-hash. * 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): Export procedures. * Makefile.am (STORE_MODULES): Add guix/store/environment.scm. Co-authored-by: Christopher Baines Change-Id: I71ac38fa8596a0c05b34880ca60e8a27ef3892d8 --- Makefile.am | 3 +- guix/store.scm | 1 + guix/store/database.scm | 88 ++++++- guix/store/environment.scm | 484 +++++++++++++++++++++++++++++++++++++ 4 files changed, 574 insertions(+), 2 deletions(-) create mode 100644 guix/store/environment.scm 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 +;;; +;;; 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 (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 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 /-." + (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 + 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))) + (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)))) + +(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 ((env (nonchroot-build-environment drv + #:gid gid + #:uid uid))) + (environment (inherit env) + (variables (get-environment-variables))))) + +(define* (chroot-build-environment drv #:key gid uid + (extra-chroot-dirs '()) + build-chroot-dirs + (tmpdir (or (getenv "TMPDIR") + "/tmp"))) + "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 tmpdir + (string-append tempname ".store") + #o1775 0 gid)) + (build-directory (make-build-directory drv uid gid)) + (inside-build-dir (string-append tmpdir "/" tempname "-0")) + (fixed-output? (fixed-output-derivation? drv)) + (input-paths (append (default-files drv) + (or build-chroot-dirs + %default-chroot-dirs) + extra-chroot-dirs))) + (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 tmpdir (string-append tempname ".chroot") + #o750 0 gid)) + (user uid) + (group gid) + (personality (default-personality drv)) + (hostname "localhost") + (domainname "(none)")))) + +(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)))