Commit | Line | Data |
---|---|---|
372c4bbc | 1 | ;;; GNU Guix --- Functional package management for GNU |
267379f8 | 2 | ;;; Copyright © 2014, 2015, 2018 David Thompson <davet@gnu.org> |
d8e98e85 | 3 | ;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> |
07ec3492 | 4 | ;;; Copyright © 2018 Mike Gerwitz <mtg@gnu.org> |
372c4bbc DT |
5 | ;;; |
6 | ;;; This file is part of GNU Guix. | |
7 | ;;; | |
8 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
9 | ;;; under the terms of the GNU General Public License as published by | |
10 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
11 | ;;; your option) any later version. | |
12 | ;;; | |
13 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
14 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | ;;; GNU General Public License for more details. | |
17 | ;;; | |
18 | ;;; You should have received a copy of the GNU General Public License | |
19 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
20 | ||
21 | (define-module (guix scripts environment) | |
22 | #:use-module (guix ui) | |
23 | #:use-module (guix store) | |
2637cfd7 | 24 | #:use-module ((guix status) #:select (with-status-verbosity)) |
7573d30f | 25 | #:use-module (guix grafts) |
372c4bbc DT |
26 | #:use-module (guix derivations) |
27 | #:use-module (guix packages) | |
28 | #:use-module (guix profiles) | |
099a2c70 | 29 | #:use-module (guix search-paths) |
f535dcbe | 30 | #:use-module (guix build utils) |
372c4bbc | 31 | #:use-module (guix monads) |
836a85da | 32 | #:use-module ((guix gexp) #:select (lower-object)) |
88981dd3 | 33 | #:use-module (guix scripts) |
372c4bbc | 34 | #:use-module (guix scripts build) |
f535dcbe | 35 | #:use-module (gnu build linux-container) |
8a9922bd | 36 | #:use-module (gnu build accounts) |
f535dcbe DT |
37 | #:use-module (gnu system linux-container) |
38 | #:use-module (gnu system file-systems) | |
372c4bbc | 39 | #:use-module (gnu packages) |
f535dcbe | 40 | #:use-module (gnu packages bash) |
836a85da LC |
41 | #:use-module ((gnu packages bootstrap) |
42 | #:select (bootstrap-executable %bootstrap-guile)) | |
372c4bbc DT |
43 | #:use-module (ice-9 format) |
44 | #:use-module (ice-9 match) | |
f535dcbe | 45 | #:use-module (ice-9 rdelim) |
372c4bbc | 46 | #:use-module (srfi srfi-1) |
417c39f1 | 47 | #:use-module (srfi srfi-11) |
372c4bbc DT |
48 | #:use-module (srfi srfi-26) |
49 | #:use-module (srfi srfi-37) | |
50 | #:use-module (srfi srfi-98) | |
90f496be LC |
51 | #:export (assert-container-features |
52 | guix-environment)) | |
372c4bbc | 53 | |
372c4bbc DT |
54 | ;; Protect some env vars from purification. Borrowed from nix-shell. |
55 | (define %precious-variables | |
56 | '("HOME" "USER" "LOGNAME" "DISPLAY" "TERM" "TZ" "PAGER")) | |
57 | ||
1de2fe95 DT |
58 | (define %default-shell |
59 | (or (getenv "SHELL") "/bin/sh")) | |
60 | ||
e6e599fa LC |
61 | (define (purify-environment white-list) |
62 | "Unset all environment variables except those that match the regexps in | |
63 | WHITE-LIST and those listed in %PRECIOUS-VARIABLES. A small number of | |
64 | variables such as 'HOME' and 'USER' are left untouched." | |
372c4bbc | 65 | (for-each unsetenv |
e6e599fa LC |
66 | (remove (lambda (variable) |
67 | (or (member variable %precious-variables) | |
68 | (find (cut regexp-exec <> variable) | |
69 | white-list))) | |
372c4bbc DT |
70 | (match (get-environment-variables) |
71 | (((names . _) ...) | |
72 | names))))) | |
73 | ||
e6e599fa LC |
74 | (define* (create-environment profile manifest |
75 | #:key pure? (white-list '())) | |
76 | "Set the environment variables specified by MANIFEST for PROFILE. When | |
77 | PURE? is #t, unset the variables in the current environment except those that | |
78 | match the regexps in WHITE-LIST. Otherwise, augment existing environment | |
79 | variables with additional search paths." | |
80 | (when pure? | |
81 | (purify-environment white-list)) | |
8e3a3bc2 LC |
82 | (for-each (match-lambda |
83 | ((($ <search-path-specification> variable _ separator) . value) | |
84 | (let ((current (getenv variable))) | |
85 | (setenv variable | |
86 | (if (and current (not pure?)) | |
50f4ea18 LC |
87 | (if separator |
88 | (string-append value separator current) | |
89 | value) | |
8e3a3bc2 | 90 | value))))) |
78d55b70 | 91 | (profile-search-paths profile manifest)) |
28de8d25 LC |
92 | |
93 | ;; Give users a way to know that they're in 'guix environment', so they can | |
20185522 LC |
94 | ;; adjust 'PS1' accordingly, for instance. Set it to PROFILE so users can |
95 | ;; conveniently access its contents. | |
96 | (setenv "GUIX_ENVIRONMENT" profile)) | |
372c4bbc | 97 | |
78d55b70 LC |
98 | (define* (show-search-paths profile manifest #:key pure?) |
99 | "Display the search paths of MANIFEST applied to PROFILE. When PURE? is #t, | |
100 | do not augment existing environment variables with additional search paths." | |
8e3a3bc2 LC |
101 | (for-each (match-lambda |
102 | ((search-path . value) | |
103 | (display | |
104 | (search-path-definition search-path value | |
105 | #:kind (if pure? 'exact 'prefix))) | |
106 | (newline))) | |
78d55b70 | 107 | (profile-search-paths profile manifest))) |
779aa003 | 108 | |
10f0a40c LC |
109 | (define (input->manifest-entry input) |
110 | "Return a manifest entry for INPUT, or #f if INPUT does not correspond to a | |
111 | package." | |
779aa003 | 112 | (match input |
10f0a40c LC |
113 | ((_ (? package? package)) |
114 | (package->manifest-entry package)) | |
115 | ((_ (? package? package) output) | |
116 | (package->manifest-entry package output)) | |
117 | (_ | |
118 | #f))) | |
779aa003 DT |
119 | |
120 | (define (package-environment-inputs package) | |
10f0a40c LC |
121 | "Return a list of manifest entries corresponding to the transitive input |
122 | packages for PACKAGE." | |
779aa003 | 123 | ;; Remove non-package inputs such as origin records. |
10f0a40c LC |
124 | (filter-map input->manifest-entry |
125 | (bag-transitive-inputs (package->bag package)))) | |
372c4bbc DT |
126 | |
127 | (define (show-help) | |
69daee23 | 128 | (display (G_ "Usage: guix environment [OPTION]... PACKAGE... [-- COMMAND...] |
1de2fe95 DT |
129 | Build an environment that includes the dependencies of PACKAGE and execute |
130 | COMMAND or an interactive shell in that environment.\n")) | |
69daee23 | 131 | (display (G_ " |
372c4bbc DT |
132 | -e, --expression=EXPR create environment for the package that EXPR |
133 | evaluates to")) | |
69daee23 | 134 | (display (G_ " |
372c4bbc DT |
135 | -l, --load=FILE create environment for the package that the code within |
136 | FILE evaluates to")) | |
267379f8 DT |
137 | (display (G_ " |
138 | -m, --manifest=FILE create environment with the manifest from FILE")) | |
69daee23 | 139 | (display (G_ " |
a54bd6d7 DT |
140 | --ad-hoc include all specified packages in the environment instead |
141 | of only their inputs")) | |
69daee23 | 142 | (display (G_ " |
b9113adf | 143 | --pure unset existing environment variables")) |
e6e599fa | 144 | (display (G_ " |
dca58219 | 145 | -E, --preserve=REGEXP preserve environment variables that match REGEXP")) |
69daee23 | 146 | (display (G_ " |
b9113adf | 147 | --search-paths display needed environment variable definitions")) |
69daee23 | 148 | (display (G_ " |
ce367ef3 | 149 | -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) |
69daee23 | 150 | (display (G_ " |
f943c317 LC |
151 | -r, --root=FILE make FILE a symlink to the result, and register it |
152 | as a garbage collector root")) | |
69daee23 | 153 | (display (G_ " |
f535dcbe | 154 | -C, --container run command within an isolated container")) |
69daee23 | 155 | (display (G_ " |
f535dcbe | 156 | -N, --network allow containers to access the network")) |
07ec3492 MG |
157 | (display (G_ " |
158 | -P, --link-profile link environment profile to ~/.guix-profile within | |
159 | an isolated container")) | |
e37944d8 MG |
160 | (display (G_ " |
161 | -u, --user=USER instead of copying the name and home of the current | |
162 | user into an isolated container, use the name USER | |
163 | with home directory /home/USER")) | |
b6dc0839 CD |
164 | (display (G_ " |
165 | --no-cwd do not share current working directory with an | |
166 | isolated container")) | |
167 | ||
69daee23 | 168 | (display (G_ " |
f535dcbe DT |
169 | --share=SPEC for containers, share writable host file system |
170 | according to SPEC")) | |
69daee23 | 171 | (display (G_ " |
f535dcbe DT |
172 | --expose=SPEC for containers, expose read-only host file system |
173 | according to SPEC")) | |
f1de676e LC |
174 | (display (G_ " |
175 | -v, --verbosity=LEVEL use the given verbosity LEVEL")) | |
69daee23 | 176 | (display (G_ " |
f535dcbe | 177 | --bootstrap use bootstrap binaries to build the environment")) |
372c4bbc DT |
178 | (newline) |
179 | (show-build-options-help) | |
180 | (newline) | |
a93c1606 LC |
181 | (show-transformation-options-help) |
182 | (newline) | |
69daee23 | 183 | (display (G_ " |
372c4bbc | 184 | -h, --help display this help and exit")) |
69daee23 | 185 | (display (G_ " |
372c4bbc | 186 | -V, --version display version information and exit")) |
b9113adf | 187 | (newline) |
372c4bbc DT |
188 | (show-bug-report-information)) |
189 | ||
190 | (define %default-options | |
7241c2fa | 191 | `((system . ,(%current-system)) |
372c4bbc | 192 | (substitutes? . #t) |
7f44ab48 | 193 | (offload? . #t) |
7573d30f | 194 | (graft? . #t) |
dc0f74e5 LC |
195 | (print-build-trace? . #t) |
196 | (print-extended-build-trace? . #t) | |
f9a8fce1 | 197 | (multiplexed-build-output? . #t) |
f1de676e | 198 | (debug . 0) |
985730c1 | 199 | (verbosity . 1))) |
372c4bbc | 200 | |
cc90fbbf DT |
201 | (define (tag-package-arg opts arg) |
202 | "Return a two-element list with the form (TAG ARG) that tags ARG with either | |
203 | 'ad-hoc' in OPTS has the 'ad-hoc?' key set to #t, or 'inputs' otherwise." | |
204 | ;; Normally, the transitive inputs to a package are added to an environment, | |
205 | ;; but the ad-hoc? flag changes the meaning of a package argument such that | |
206 | ;; the package itself is added to the environment instead. | |
207 | (if (assoc-ref opts 'ad-hoc?) | |
208 | `(ad-hoc-package ,arg) | |
209 | `(package ,arg))) | |
210 | ||
372c4bbc DT |
211 | (define %options |
212 | ;; Specification of the command-line options. | |
213 | (cons* (option '(#\h "help") #f #f | |
214 | (lambda args | |
215 | (show-help) | |
216 | (exit 0))) | |
217 | (option '(#\V "version") #f #f | |
218 | (lambda args | |
219 | (show-version-and-exit "guix environment"))) | |
220 | (option '("pure") #f #f | |
221 | (lambda (opt name arg result) | |
222 | (alist-cons 'pure #t result))) | |
dca58219 | 223 | (option '(#\E "preserve") #t #f |
e6e599fa LC |
224 | (lambda (opt name arg result) |
225 | (alist-cons 'inherit-regexp | |
226 | (make-regexp* arg) | |
227 | result))) | |
dca58219 LC |
228 | (option '("inherit") #t #f ;deprecated |
229 | (lambda (opt name arg result) | |
230 | (warning (G_ "'--inherit' is deprecated, \ | |
231 | use '--preserve' instead~%")) | |
232 | (alist-cons 'inherit-regexp | |
233 | (make-regexp* arg) | |
234 | result))) | |
372c4bbc DT |
235 | (option '("search-paths") #f #f |
236 | (lambda (opt name arg result) | |
237 | (alist-cons 'search-paths #t result))) | |
238 | (option '(#\l "load") #t #f | |
239 | (lambda (opt name arg result) | |
cc90fbbf DT |
240 | (alist-cons 'load |
241 | (tag-package-arg result arg) | |
242 | result))) | |
372c4bbc DT |
243 | (option '(#\e "expression") #t #f |
244 | (lambda (opt name arg result) | |
cc90fbbf DT |
245 | (alist-cons 'expression |
246 | (tag-package-arg result arg) | |
247 | result))) | |
267379f8 DT |
248 | (option '(#\m "manifest") #t #f |
249 | (lambda (opt name arg result) | |
250 | (alist-cons 'manifest | |
251 | arg | |
252 | result))) | |
a54bd6d7 DT |
253 | (option '("ad-hoc") #f #f |
254 | (lambda (opt name arg result) | |
255 | (alist-cons 'ad-hoc? #t result))) | |
372c4bbc DT |
256 | (option '(#\n "dry-run") #f #f |
257 | (lambda (opt name arg result) | |
131f50cd | 258 | (alist-cons 'dry-run? #t result))) |
ce367ef3 LC |
259 | (option '(#\s "system") #t #f |
260 | (lambda (opt name arg result) | |
261 | (alist-cons 'system arg | |
262 | (alist-delete 'system result eq?)))) | |
f535dcbe DT |
263 | (option '(#\C "container") #f #f |
264 | (lambda (opt name arg result) | |
265 | (alist-cons 'container? #t result))) | |
266 | (option '(#\N "network") #f #f | |
267 | (lambda (opt name arg result) | |
268 | (alist-cons 'network? #t result))) | |
07ec3492 MG |
269 | (option '(#\P "link-profile") #f #f |
270 | (lambda (opt name arg result) | |
271 | (alist-cons 'link-profile? #t result))) | |
e37944d8 MG |
272 | (option '(#\u "user") #t #f |
273 | (lambda (opt name arg result) | |
274 | (alist-cons 'user arg | |
275 | (alist-delete 'user result eq?)))) | |
b6dc0839 CD |
276 | (option '("no-cwd") #f #f |
277 | (lambda (opt name arg result) | |
278 | (alist-cons 'no-cwd? #t result))) | |
f535dcbe DT |
279 | (option '("share") #t #f |
280 | (lambda (opt name arg result) | |
281 | (alist-cons 'file-system-mapping | |
282 | (specification->file-system-mapping arg #t) | |
283 | result))) | |
284 | (option '("expose") #t #f | |
285 | (lambda (opt name arg result) | |
286 | (alist-cons 'file-system-mapping | |
287 | (specification->file-system-mapping arg #f) | |
288 | result))) | |
f943c317 LC |
289 | (option '(#\r "root") #t #f |
290 | (lambda (opt name arg result) | |
291 | (alist-cons 'gc-root arg result))) | |
f1de676e LC |
292 | (option '(#\v "verbosity") #t #f |
293 | (lambda (opt name arg result) | |
294 | (let ((level (string->number* arg))) | |
295 | (alist-cons 'verbosity level | |
296 | (alist-delete 'verbosity result))))) | |
f535dcbe DT |
297 | (option '("bootstrap") #f #f |
298 | (lambda (opt name arg result) | |
299 | (alist-cons 'bootstrap? #t result))) | |
a93c1606 LC |
300 | |
301 | (append %transformation-options | |
302 | %standard-build-options))) | |
372c4bbc DT |
303 | |
304 | (define (pick-all alist key) | |
305 | "Return a list of values in ALIST associated with KEY." | |
306 | (define same-key? (cut eq? key <>)) | |
307 | ||
308 | (fold (lambda (pair memo) | |
309 | (match pair | |
310 | (((? same-key? k) . v) | |
311 | (cons v memo)) | |
312 | (_ memo))) | |
313 | '() alist)) | |
314 | ||
a93c1606 | 315 | (define (options/resolve-packages store opts) |
10f0a40c LC |
316 | "Return OPTS with package specification strings replaced by manifest entries |
317 | for the corresponding packages." | |
318 | (define (manifest-entry=? e1 e2) | |
319 | (and (eq? (manifest-entry-item e1) (manifest-entry-item e2)) | |
320 | (string=? (manifest-entry-output e1) | |
321 | (manifest-entry-output e2)))) | |
c9c282ce | 322 | |
a93c1606 LC |
323 | (define transform |
324 | (cut (options->transformation opts) store <>)) | |
325 | ||
326 | (define* (package->manifest-entry* package #:optional (output "out")) | |
327 | (package->manifest-entry (transform package) output)) | |
328 | ||
c9c282ce DT |
329 | (define (packages->outputs packages mode) |
330 | (match packages | |
10f0a40c LC |
331 | ((? package? package) |
332 | (if (eq? mode 'ad-hoc-package) | |
a93c1606 | 333 | (list (package->manifest-entry* package)) |
10f0a40c LC |
334 | (package-environment-inputs package))) |
335 | (((? package? package) (? string? output)) | |
336 | (if (eq? mode 'ad-hoc-package) | |
a93c1606 | 337 | (list (package->manifest-entry* package output)) |
10f0a40c LC |
338 | (package-environment-inputs package))) |
339 | ((lst ...) | |
340 | (append-map (cut packages->outputs <> mode) lst)))) | |
341 | ||
342 | (manifest | |
343 | (delete-duplicates | |
344 | (append-map (match-lambda | |
345 | (('package 'ad-hoc-package (? string? spec)) | |
346 | (let-values (((package output) | |
347 | (specification->package+output spec))) | |
a93c1606 | 348 | (list (package->manifest-entry* package output)))) |
10f0a40c LC |
349 | (('package 'package (? string? spec)) |
350 | (package-environment-inputs | |
d108f597 | 351 | (transform (specification->package+output spec)))) |
10f0a40c LC |
352 | (('expression mode str) |
353 | ;; Add all the outputs of the package STR evaluates to. | |
354 | (packages->outputs (read/eval str) mode)) | |
355 | (('load mode file) | |
356 | ;; Add all the outputs of the package defined in FILE. | |
357 | (let ((module (make-user-module '()))) | |
358 | (packages->outputs (load* file module) mode))) | |
359 | (('manifest . file) | |
360 | (let ((module (make-user-module '((guix profiles) (gnu))))) | |
361 | (manifest-entries (load* file module)))) | |
362 | (_ '())) | |
363 | opts) | |
364 | manifest-entry=?))) | |
372c4bbc | 365 | |
10f0a40c LC |
366 | (define (manifest->derivation manifest system bootstrap?) |
367 | "Return the derivation for a profile of MANIFEST. | |
368 | BOOTSTRAP? specifies whether to use the bootstrap Guile to build the profile." | |
369 | (profile-derivation manifest | |
779aa003 | 370 | #:system system |
afd06f60 LC |
371 | |
372 | ;; Packages can have conflicting inputs, or explicit | |
373 | ;; inputs that conflict with implicit inputs (e.g., gcc, | |
374 | ;; gzip, etc.). Thus, do not error out when we | |
375 | ;; encounter collision. | |
376 | #:allow-collisions? #t | |
377 | ||
779aa003 DT |
378 | #:hooks (if bootstrap? |
379 | '() | |
a6562c7e LC |
380 | %default-profile-hooks) |
381 | #:locales? (not bootstrap?))) | |
372c4bbc | 382 | |
f535dcbe DT |
383 | (define requisites* (store-lift requisites)) |
384 | ||
385 | (define (inputs->requisites inputs) | |
386 | "Convert INPUTS, a list of input tuples or store path strings, into a set of | |
387 | requisite store items i.e. the union closure of all the inputs." | |
388 | (define (input->requisites input) | |
389 | (requisites* | |
390 | (match input | |
391 | ((drv output) | |
f6fee16e | 392 | (list (derivation->output-path drv output))) |
f535dcbe | 393 | ((drv) |
f6fee16e | 394 | (list (derivation->output-path drv))) |
f535dcbe | 395 | ((? direct-store-path? path) |
f6fee16e | 396 | (list path))))) |
f535dcbe | 397 | |
b334674f LC |
398 | (mlet %store-monad ((reqs (mapm %store-monad |
399 | input->requisites inputs))) | |
f535dcbe DT |
400 | (return (delete-duplicates (concatenate reqs))))) |
401 | ||
82e64fc1 LC |
402 | (define (status->exit-code status) |
403 | "Compute the exit code made from STATUS, a value as returned by 'waitpid', | |
404 | and suitable for 'exit'." | |
405 | ;; See <bits/waitstatus.h>. | |
406 | (or (status:exit-val status) | |
407 | (logior #x80 (status:term-sig status)))) | |
408 | ||
409 | (define exit/status (compose exit status->exit-code)) | |
410 | (define primitive-exit/status (compose primitive-exit status->exit-code)) | |
f535dcbe | 411 | |
78d55b70 | 412 | (define* (launch-environment command profile manifest |
e6e599fa | 413 | #:key pure? (white-list '())) |
f535dcbe DT |
414 | "Run COMMAND in a new environment containing INPUTS, using the native search |
415 | paths defined by the list PATHS. When PURE?, pre-existing environment | |
e6e599fa LC |
416 | variables are cleared before setting the new ones, except those matching the |
417 | regexps in WHITE-LIST." | |
13bc8d5e DT |
418 | ;; Properly handle SIGINT, so pressing C-c in an interactive terminal |
419 | ;; application works. | |
420 | (sigaction SIGINT SIG_DFL) | |
e6e599fa LC |
421 | (create-environment profile manifest |
422 | #:pure? pure? #:white-list white-list) | |
13bc8d5e DT |
423 | (match command |
424 | ((program . args) | |
425 | (apply execlp program program args)))) | |
426 | ||
e6e599fa LC |
427 | (define* (launch-environment/fork command profile manifest |
428 | #:key pure? (white-list '())) | |
78d55b70 LC |
429 | "Run COMMAND in a new process with an environment containing PROFILE, with |
430 | the search paths specified by MANIFEST. When PURE?, pre-existing environment | |
e6e599fa LC |
431 | variables are cleared before setting the new ones, except those matching the |
432 | regexps in WHITE-LIST." | |
13bc8d5e | 433 | (match (primitive-fork) |
78d55b70 | 434 | (0 (launch-environment command profile manifest |
e6e599fa LC |
435 | #:pure? pure? |
436 | #:white-list white-list)) | |
13bc8d5e DT |
437 | (pid (match (waitpid pid) |
438 | ((_ . status) status))))) | |
f535dcbe | 439 | |
e37944d8 | 440 | (define* (launch-environment/container #:key command bash user user-mappings |
b6dc0839 | 441 | profile manifest link-profile? network? |
5a02f8e3 | 442 | map-cwd? (white-list '())) |
779aa003 | 443 | "Run COMMAND within a container that features the software in PROFILE. |
78d55b70 LC |
444 | Environment variables are set according to the search paths of MANIFEST. |
445 | The global shell is BASH, a file name for a GNU Bash binary in the | |
779aa003 DT |
446 | store. When NETWORK?, access to the host system network is permitted. |
447 | USER-MAPPINGS, a list of file system mappings, contains the user-specified | |
e37944d8 MG |
448 | host file systems to mount inside the container. If USER is not #f, each |
449 | target of USER-MAPPINGS will be re-written relative to '/home/USER', and USER | |
450 | will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from | |
5a02f8e3 LC |
451 | ~/.guix-profile to the environment profile. |
452 | ||
453 | Preserve environment variables whose name matches the one of the regexps in | |
454 | WHILE-LIST." | |
5ccec771 LC |
455 | (define (optional-mapping->fs mapping) |
456 | (and (file-exists? (file-system-mapping-source mapping)) | |
457 | (file-system-mapping->bind-mount mapping))) | |
458 | ||
f535dcbe | 459 | (mlet %store-monad ((reqs (inputs->requisites |
779aa003 | 460 | (list (direct-store-path bash) profile)))) |
f535dcbe | 461 | (return |
07ec3492 | 462 | (let* ((cwd (getcwd)) |
e37944d8 | 463 | (home (getenv "HOME")) |
1ccc0f80 LC |
464 | (uid (if user 1000 (getuid))) |
465 | (gid (if user 1000 (getgid))) | |
8a9922bd LC |
466 | (passwd (let ((pwd (getpwuid (getuid)))) |
467 | (password-entry | |
468 | (name (or user (passwd:name pwd))) | |
469 | (real-name (if user | |
470 | "" | |
471 | (passwd:gecos pwd))) | |
1ccc0f80 | 472 | (uid uid) (gid gid) (shell bash) |
8a9922bd LC |
473 | (directory (if user |
474 | (string-append "/home/" user) | |
475 | (passwd:dir pwd)))))) | |
1ccc0f80 | 476 | (groups (list (group-entry (name "users") (gid gid)) |
952afb6f LC |
477 | (group-entry (gid 65534) ;the overflow GID |
478 | (name "overflow")))) | |
8a9922bd | 479 | (home-dir (password-entry-directory passwd)) |
bc8be17c | 480 | (logname (password-entry-name passwd)) |
5a02f8e3 LC |
481 | (environ (filter (match-lambda |
482 | ((variable . value) | |
483 | (find (cut regexp-exec <> variable) | |
484 | white-list))) | |
485 | (get-environment-variables))) | |
f535dcbe DT |
486 | ;; Bind-mount all requisite store items, user-specified mappings, |
487 | ;; /bin/sh, the current working directory, and possibly networking | |
488 | ;; configuration files within the container. | |
489 | (mappings | |
a655d504 CD |
490 | (append |
491 | (override-user-mappings | |
492 | user home | |
493 | (append user-mappings | |
b6dc0839 CD |
494 | ;; Share current working directory, unless asked not to. |
495 | (if map-cwd? | |
496 | (list (file-system-mapping | |
497 | (source cwd) | |
498 | (target cwd) | |
499 | (writable? #t))) | |
500 | '()))) | |
a655d504 CD |
501 | ;; Mappings for the union closure of all inputs. |
502 | (map (lambda (dir) | |
503 | (file-system-mapping | |
504 | (source dir) | |
505 | (target dir) | |
506 | (writable? #f))) | |
507 | reqs))) | |
f535dcbe | 508 | (file-systems (append %container-file-systems |
5ccec771 LC |
509 | (if network? |
510 | (filter-map optional-mapping->fs | |
511 | %network-file-mappings) | |
512 | '()) | |
d2a5e698 LC |
513 | (map file-system-mapping->bind-mount |
514 | mappings)))) | |
f535dcbe | 515 | (exit/status |
5970e8e2 | 516 | (call-with-container file-systems |
f535dcbe DT |
517 | (lambda () |
518 | ;; Setup global shell. | |
519 | (mkdir-p "/bin") | |
520 | (symlink bash "/bin/sh") | |
521 | ||
aa2a0d4b DT |
522 | ;; Set a reasonable default PS1. |
523 | (setenv "PS1" "\\u@\\h \\w [env]\\$ ") | |
524 | ||
f535dcbe DT |
525 | ;; Setup directory for temporary files. |
526 | (mkdir-p "/tmp") | |
527 | (for-each (lambda (var) | |
528 | (setenv var "/tmp")) | |
529 | ;; The same variables as in Nix's 'build.cc'. | |
530 | '("TMPDIR" "TEMPDIR" "TMP" "TEMP")) | |
531 | ||
bc8be17c LDB |
532 | ;; Some programs expect USER and/or LOGNAME to be set. |
533 | (setenv "LOGNAME" logname) | |
534 | (setenv "USER" logname) | |
535 | ||
e37944d8 | 536 | ;; Create a dummy home directory. |
07ec3492 MG |
537 | (mkdir-p home-dir) |
538 | (setenv "HOME" home-dir) | |
539 | ||
540 | ;; If requested, link $GUIX_ENVIRONMENT to $HOME/.guix-profile; | |
541 | ;; this allows programs expecting that path to continue working as | |
542 | ;; expected within a container. | |
543 | (when link-profile? (link-environment profile home-dir)) | |
a01ad638 DT |
544 | |
545 | ;; Create a dummy /etc/passwd to satisfy applications that demand | |
546 | ;; to read it, such as 'git clone' over SSH, a valid use-case when | |
547 | ;; sharing the host's network namespace. | |
548 | (mkdir-p "/etc") | |
8a9922bd | 549 | (write-passwd (list passwd)) |
952afb6f | 550 | (write-group groups) |
f535dcbe DT |
551 | |
552 | ;; For convenience, start in the user's current working | |
b6dc0839 CD |
553 | ;; directory or, if unmapped, the home directory. |
554 | (chdir (if map-cwd? | |
555 | (override-user-dir user home cwd) | |
556 | home-dir)) | |
f535dcbe | 557 | |
5a02f8e3 LC |
558 | ;; Set environment variables that match WHITE-LIST. |
559 | (for-each (match-lambda | |
560 | ((variable . value) | |
561 | (setenv variable value))) | |
562 | environ) | |
563 | ||
f535dcbe DT |
564 | (primitive-exit/status |
565 | ;; A container's environment is already purified, so no need to | |
566 | ;; request it be purified again. | |
9b65281d LC |
567 | (launch-environment command |
568 | (if link-profile? | |
569 | (string-append home-dir "/.guix-profile") | |
570 | profile) | |
571 | manifest #:pure? #f))) | |
1ccc0f80 LC |
572 | #:guest-uid uid |
573 | #:guest-gid gid | |
f535dcbe DT |
574 | #:namespaces (if network? |
575 | (delq 'net %namespaces) ; share host network | |
576 | %namespaces))))))) | |
577 | ||
e37944d8 MG |
578 | (define (user-override-home user) |
579 | "Return home directory for override user USER." | |
580 | (string-append "/home/" user)) | |
581 | ||
582 | (define (override-user-mappings user home mappings) | |
583 | "If a username USER is provided, rewrite each HOME prefix in file system | |
584 | mappings MAPPINGS to a home directory determined by 'override-user-dir'; | |
585 | otherwise, return MAPPINGS." | |
586 | (if (not user) | |
587 | mappings | |
588 | (map (lambda (mapping) | |
589 | (let ((target (file-system-mapping-target mapping))) | |
590 | (if (string-prefix? home target) | |
591 | (file-system-mapping | |
592 | (source (file-system-mapping-source mapping)) | |
593 | (target (override-user-dir user home target)) | |
594 | (writable? (file-system-mapping-writable? mapping))) | |
595 | mapping))) | |
596 | mappings))) | |
597 | ||
598 | (define (override-user-dir user home dir) | |
599 | "If username USER is provided, overwrite string prefix HOME in DIR with a | |
600 | directory determined by 'user-override-home'; otherwise, return DIR." | |
601 | (if (and user (string-prefix? home dir)) | |
602 | (string-append (user-override-home user) | |
603 | (substring dir (string-length home))) | |
604 | dir)) | |
605 | ||
07ec3492 MG |
606 | (define (link-environment profile home-dir) |
607 | "Create a symbolic link from HOME-DIR/.guix-profile to PROFILE." | |
608 | (let ((profile-dir (string-append home-dir "/.guix-profile"))) | |
609 | (catch 'system-error | |
610 | (lambda () | |
611 | (symlink profile profile-dir)) | |
612 | (lambda args | |
613 | (if (= EEXIST (system-error-errno args)) | |
614 | (leave (G_ "cannot link profile: '~a' already exists within container~%") | |
615 | profile-dir) | |
616 | (apply throw args)))))) | |
617 | ||
f535dcbe DT |
618 | (define (environment-bash container? bootstrap? system) |
619 | "Return a monadic value in the store monad for the version of GNU Bash | |
620 | needed in the environment for SYSTEM, if any. If CONTAINER? is #f, return #f. | |
621 | If CONTAINER? and BOOTSTRAP?, return the store path for the bootstrap Bash. | |
622 | Otherwise, return the derivation for the Bash package." | |
623 | (with-monad %store-monad | |
624 | (cond | |
625 | ((and container? (not bootstrap?)) | |
626 | (package->derivation bash)) | |
627 | ;; Use the bootstrap Bash instead. | |
628 | ((and container? bootstrap?) | |
836a85da | 629 | (lower-object (bootstrap-executable "bash" system))) |
f535dcbe DT |
630 | (else |
631 | (return #f))))) | |
632 | ||
1de2fe95 DT |
633 | (define (parse-args args) |
634 | "Parse the list of command line arguments ARGS." | |
b3f21389 | 635 | (define (handle-argument arg result) |
cc90fbbf | 636 | (alist-cons 'package (tag-package-arg result arg) result)) |
372c4bbc | 637 | |
1de2fe95 DT |
638 | ;; The '--' token is used to separate the command to run from the rest of |
639 | ;; the operands. | |
6aaf3ea6 | 640 | (let-values (((args command) (break (cut string=? "--" <>) args))) |
1de2fe95 DT |
641 | (let ((opts (parse-command-line args %options (list %default-options) |
642 | #:argument-handler handle-argument))) | |
6aaf3ea6 LC |
643 | (match command |
644 | (() opts) | |
645 | (("--") opts) | |
646 | (("--" command ...) (alist-cons 'exec command opts)))))) | |
1de2fe95 | 647 | |
00bfa7ea DT |
648 | (define (assert-container-features) |
649 | "Check if containers can be created and exit with an informative error | |
650 | message if any test fails." | |
651 | (unless (user-namespace-supported?) | |
69daee23 LC |
652 | (report-error (G_ "cannot create container: user namespaces unavailable\n")) |
653 | (leave (G_ "is your kernel version < 3.10?\n"))) | |
00bfa7ea DT |
654 | |
655 | (unless (unprivileged-user-namespace-supported?) | |
69daee23 LC |
656 | (report-error (G_ "cannot create container: unprivileged user cannot create user namespaces\n")) |
657 | (leave (G_ "please set /proc/sys/kernel/unprivileged_userns_clone to \"1\"\n"))) | |
00bfa7ea DT |
658 | |
659 | (unless (setgroups-supported?) | |
69daee23 LC |
660 | (report-error (G_ "cannot create container: /proc/self/setgroups does not exist\n")) |
661 | (leave (G_ "is your kernel version < 3.19?\n")))) | |
00bfa7ea | 662 | |
f943c317 LC |
663 | (define (register-gc-root target root) |
664 | "Make ROOT an indirect root to TARGET. This is procedure is idempotent." | |
840f38ba LC |
665 | (let* ((root (if (string-prefix? "/" root) |
666 | root | |
667 | (string-append (canonicalize-path (dirname root)) | |
668 | "/" root)))) | |
f943c317 LC |
669 | (catch 'system-error |
670 | (lambda () | |
671 | (symlink target root) | |
672 | ((store-lift add-indirect-root) root)) | |
673 | (lambda args | |
674 | (if (and (= EEXIST (system-error-errno args)) | |
675 | (equal? (false-if-exception (readlink root)) target)) | |
676 | (with-monad %store-monad | |
677 | (return #t)) | |
678 | (apply throw args)))))) | |
679 | ||
680 | \f | |
681 | ;;; | |
682 | ;;; Entry point. | |
683 | ;;; | |
684 | ||
3794ce93 LC |
685 | (define-command (guix-environment . args) |
686 | (category development) | |
687 | (synopsis "spawn one-off software environments") | |
688 | ||
5762f306 | 689 | (with-error-handling |
f535dcbe DT |
690 | (let* ((opts (parse-args args)) |
691 | (pure? (assoc-ref opts 'pure)) | |
692 | (container? (assoc-ref opts 'container?)) | |
07ec3492 | 693 | (link-prof? (assoc-ref opts 'link-profile?)) |
f535dcbe | 694 | (network? (assoc-ref opts 'network?)) |
b6dc0839 | 695 | (no-cwd? (assoc-ref opts 'no-cwd?)) |
e37944d8 | 696 | (user (assoc-ref opts 'user)) |
f535dcbe DT |
697 | (bootstrap? (assoc-ref opts 'bootstrap?)) |
698 | (system (assoc-ref opts 'system)) | |
7241c2fa DT |
699 | (command (or (assoc-ref opts 'exec) |
700 | ;; Spawn a shell if the user didn't specify | |
701 | ;; anything in particular. | |
702 | (if container? | |
703 | ;; The user's shell is likely not available | |
704 | ;; within the container. | |
705 | '("/bin/sh") | |
706 | (list %default-shell)))) | |
e6e599fa LC |
707 | (mappings (pick-all opts 'file-system-mapping)) |
708 | (white-list (pick-all opts 'inherit-regexp))) | |
00bfa7ea DT |
709 | |
710 | (when container? (assert-container-features)) | |
711 | ||
07ec3492 MG |
712 | (when (and (not container?) link-prof?) |
713 | (leave (G_ "'--link-profile' cannot be used without '--container'~%"))) | |
e37944d8 MG |
714 | (when (and (not container?) user) |
715 | (leave (G_ "'--user' cannot be used without '--container'~%"))) | |
b6dc0839 CD |
716 | (when (and (not container?) no-cwd?) |
717 | (leave (G_ "--no-cwd cannot be used without --container~%"))) | |
718 | ||
07ec3492 | 719 | |
c2590362 | 720 | (with-store store |
c74f19d7 LC |
721 | (with-build-handler (build-notifier #:use-substitutes? |
722 | (assoc-ref opts 'substitutes?) | |
898e6d0a LC |
723 | #:verbosity |
724 | (assoc-ref opts 'verbosity) | |
c74f19d7 LC |
725 | #:dry-run? |
726 | (assoc-ref opts 'dry-run?)) | |
727 | (with-status-verbosity (assoc-ref opts 'verbosity) | |
728 | (define manifest | |
729 | (options/resolve-packages store opts)) | |
730 | ||
731 | (set-build-options-from-command-line store opts) | |
732 | ||
733 | ;; Use the bootstrap Guile when requested. | |
734 | (parameterize ((%graft? (assoc-ref opts 'graft?)) | |
735 | (%guile-for-build | |
736 | (package-derivation | |
737 | store | |
738 | (if bootstrap? | |
739 | %bootstrap-guile | |
18af6870 | 740 | (default-guile))))) |
c74f19d7 LC |
741 | (run-with-store store |
742 | ;; Containers need a Bourne shell at /bin/sh. | |
743 | (mlet* %store-monad ((bash (environment-bash container? | |
744 | bootstrap? | |
745 | system)) | |
746 | (prof-drv (manifest->derivation | |
747 | manifest system bootstrap?)) | |
748 | (profile -> (derivation->output-path prof-drv)) | |
749 | (gc-root -> (assoc-ref opts 'gc-root))) | |
750 | ||
751 | ;; First build the inputs. This is necessary even for | |
752 | ;; --search-paths. Additionally, we might need to build bash for | |
753 | ;; a container. | |
754 | (mbegin %store-monad | |
755 | (built-derivations (if (derivation? bash) | |
756 | (list prof-drv bash) | |
757 | (list prof-drv))) | |
758 | (mwhen gc-root | |
759 | (register-gc-root profile gc-root)) | |
760 | ||
761 | (cond | |
762 | ((assoc-ref opts 'search-paths) | |
763 | (show-search-paths profile manifest #:pure? pure?) | |
764 | (return #t)) | |
765 | (container? | |
766 | (let ((bash-binary | |
767 | (if bootstrap? | |
768 | (derivation->output-path bash) | |
769 | (string-append (derivation->output-path bash) | |
770 | "/bin/sh")))) | |
771 | (launch-environment/container #:command command | |
772 | #:bash bash-binary | |
773 | #:user user | |
774 | #:user-mappings mappings | |
775 | #:profile profile | |
776 | #:manifest manifest | |
777 | #:white-list white-list | |
778 | #:link-profile? link-prof? | |
779 | #:network? network? | |
780 | #:map-cwd? (not no-cwd?)))) | |
781 | ||
782 | (else | |
783 | (return | |
784 | (exit/status | |
785 | (launch-environment/fork command profile manifest | |
786 | #:white-list white-list | |
787 | #:pure? pure?))))))))))))))) |