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