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