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