1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2014, 2015 David Thompson <davet@gnu.org>
3 ;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
5 ;;; This file is part of GNU Guix.
7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
8 ;;; under the terms of the GNU General Public License as published by
9 ;;; the Free Software Foundation; either version 3 of the License, or (at
10 ;;; your option) any later version.
12 ;;; GNU Guix is distributed in the hope that it will be useful, but
13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;;; GNU General Public License for more details.
17 ;;; You should have received a copy of the GNU General Public License
18 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
20 (define-module (guix scripts environment)
21 #:use-module (guix ui)
22 #:use-module (guix store)
23 #:use-module (guix derivations)
24 #:use-module (guix packages)
25 #:use-module (guix profiles)
26 #:use-module (guix search-paths)
27 #:use-module (guix utils)
28 #:use-module (guix build utils)
29 #:use-module (guix monads)
30 #:use-module ((guix gexp) #:select (lower-inputs))
31 #:use-module (guix scripts)
32 #:use-module (guix scripts build)
33 #:use-module (gnu build linux-container)
34 #:use-module (gnu system linux-container)
35 #:use-module (gnu system file-systems)
36 #:use-module (gnu packages)
37 #:use-module (gnu packages bash)
38 #:use-module (ice-9 format)
39 #:use-module (ice-9 match)
40 #:use-module (ice-9 rdelim)
41 #:use-module (srfi srfi-1)
42 #:use-module (srfi srfi-11)
43 #:use-module (srfi srfi-26)
44 #:use-module (srfi srfi-37)
45 #:use-module (srfi srfi-98)
46 #:export (guix-environment))
48 (define (evaluate-input-search-paths inputs search-paths)
49 "Evaluate SEARCH-PATHS, a list of search-path specifications, for the
50 directories corresponding to INPUTS, a list of (DERIVATION) or (DERIVATION
52 (let ((directories (map (match-lambda
53 (((? derivation? drv))
54 (derivation->output-path drv))
55 (((? derivation? drv) output)
56 (derivation->output-path drv output))
60 (evaluate-search-paths search-paths directories)))
62 ;; Protect some env vars from purification. Borrowed from nix-shell.
63 (define %precious-variables
64 '("HOME" "USER" "LOGNAME" "DISPLAY" "TERM" "TZ" "PAGER"))
66 (define %default-shell
67 (or (getenv "SHELL") "/bin/sh"))
69 (define %network-configuration-files
75 (define (purify-environment)
76 "Unset almost all environment variables. A small number of variables such
77 as 'HOME' and 'USER' are left untouched."
79 (remove (cut member <> %precious-variables)
80 (match (get-environment-variables)
84 (define (create-environment inputs paths pure?)
85 "Set the environment variables specified by PATHS for all the packages
86 within INPUTS. When PURE? is #t, unset the variables in the current
87 environment. Otherwise, augment existing enviroment variables with additional
89 (when pure? (purify-environment))
90 (for-each (match-lambda
91 ((($ <search-path-specification> variable _ separator) . value)
92 (let ((current (getenv variable)))
94 (if (and current (not pure?))
95 (string-append value separator current)
97 (evaluate-input-search-paths inputs paths))
99 ;; Give users a way to know that they're in 'guix environment', so they can
100 ;; adjust 'PS1' accordingly, for instance.
101 (setenv "GUIX_ENVIRONMENT" "t"))
103 (define (show-search-paths inputs search-paths pure?)
104 "Display SEARCH-PATHS applied to the packages specified by INPUTS, a list of
105 (DERIVATION) or (DERIVATION OUTPUT) tuples. When PURE? is #t, do not augment
106 existing environment variables with additional search paths."
107 (for-each (match-lambda
108 ((search-path . value)
110 (search-path-definition search-path value
111 #:kind (if pure? 'exact 'prefix)))
113 (evaluate-input-search-paths inputs search-paths)))
115 (define (package+propagated-inputs package output)
116 "Return the union of PACKAGE's OUTPUT and its transitive propagated inputs."
117 `((,(package-name package) ,package ,output)
118 ,@(package-transitive-propagated-inputs package)))
121 (display (_ "Usage: guix environment [OPTION]... PACKAGE... [-- COMMAND...]
122 Build an environment that includes the dependencies of PACKAGE and execute
123 COMMAND or an interactive shell in that environment.\n"))
125 -e, --expression=EXPR create environment for the package that EXPR
128 -l, --load=FILE create environment for the package that the code within
131 --ad-hoc include all specified packages in the environment instead
132 of only their inputs"))
134 --pure unset existing environment variables"))
136 --search-paths display needed environment variable definitions"))
138 -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\""))
140 -C, --container run command within an isolated container"))
142 -N, --network allow containers to access the network"))
144 --share=SPEC for containers, share writable host file system
147 --expose=SPEC for containers, expose read-only host file system
150 --bootstrap use bootstrap binaries to build the environment"))
152 (show-build-options-help)
155 -h, --help display this help and exit"))
157 -V, --version display version information and exit"))
159 (show-bug-report-information))
161 (define %default-options
162 ;; Default to opening a new shell.
163 `((exec . (,%default-shell))
164 (system . ,(%current-system))
166 (max-silent-time . 3600)
169 (define (tag-package-arg opts arg)
170 "Return a two-element list with the form (TAG ARG) that tags ARG with either
171 'ad-hoc' in OPTS has the 'ad-hoc?' key set to #t, or 'inputs' otherwise."
172 ;; Normally, the transitive inputs to a package are added to an environment,
173 ;; but the ad-hoc? flag changes the meaning of a package argument such that
174 ;; the package itself is added to the environment instead.
175 (if (assoc-ref opts 'ad-hoc?)
176 `(ad-hoc-package ,arg)
180 ;; Specification of the command-line options.
181 (cons* (option '(#\h "help") #f #f
185 (option '(#\V "version") #f #f
187 (show-version-and-exit "guix environment")))
188 (option '("pure") #f #f
189 (lambda (opt name arg result)
190 (alist-cons 'pure #t result)))
191 (option '(#\E "exec") #t #f ; deprecated
192 (lambda (opt name arg result)
193 (alist-cons 'exec (list %default-shell "-c" arg) result)))
194 (option '("search-paths") #f #f
195 (lambda (opt name arg result)
196 (alist-cons 'search-paths #t result)))
197 (option '(#\l "load") #t #f
198 (lambda (opt name arg result)
200 (tag-package-arg result arg)
202 (option '(#\e "expression") #t #f
203 (lambda (opt name arg result)
204 (alist-cons 'expression
205 (tag-package-arg result arg)
207 (option '("ad-hoc") #f #f
208 (lambda (opt name arg result)
209 (alist-cons 'ad-hoc? #t result)))
210 (option '(#\n "dry-run") #f #f
211 (lambda (opt name arg result)
212 (alist-cons 'dry-run? #t result)))
213 (option '(#\s "system") #t #f
214 (lambda (opt name arg result)
215 (alist-cons 'system arg
216 (alist-delete 'system result eq?))))
217 (option '(#\C "container") #f #f
218 (lambda (opt name arg result)
219 (alist-cons 'container? #t result)))
220 (option '(#\N "network") #f #f
221 (lambda (opt name arg result)
222 (alist-cons 'network? #t result)))
223 (option '("share") #t #f
224 (lambda (opt name arg result)
225 (alist-cons 'file-system-mapping
226 (specification->file-system-mapping arg #t)
228 (option '("expose") #t #f
229 (lambda (opt name arg result)
230 (alist-cons 'file-system-mapping
231 (specification->file-system-mapping arg #f)
233 (option '("bootstrap") #f #f
234 (lambda (opt name arg result)
235 (alist-cons 'bootstrap? #t result)))
236 %standard-build-options))
238 (define (pick-all alist key)
239 "Return a list of values in ALIST associated with KEY."
240 (define same-key? (cut eq? key <>))
242 (fold (lambda (pair memo)
244 (((? same-key? k) . v)
249 (define (compact lst)
250 "Remove all #f elements from LST."
251 (filter identity lst))
253 (define (options/resolve-packages opts)
254 "Return OPTS with package specification strings replaced by actual
256 (define (package->outputs package mode)
257 (map (lambda (output)
258 (list mode package output))
259 (package-outputs package)))
261 (define (packages->outputs packages mode)
263 ((? package? package)
264 (package->outputs package mode))
265 (((? package? packages) ...)
266 (append-map (cut package->outputs <> mode) packages))))
269 (append-map (match-lambda
270 (('package mode (? string? spec))
271 (let-values (((package output)
272 (specification->package+output spec)))
273 (list (list mode package output))))
274 (('expression mode str)
275 ;; Add all the outputs of the package STR evaluates to.
276 (packages->outputs (read/eval str) mode))
278 ;; Add all the outputs of the package defined in FILE.
279 (let ((module (make-user-module '())))
280 (packages->outputs (load* file module) mode)))
284 (define (build-inputs inputs opts)
285 "Build the derivations in INPUTS, a list of (DERIVATION) or (DERIVATION
286 OUTPUT) tuples, using the build options in OPTS."
287 (let ((substitutes? (assoc-ref opts 'substitutes?))
288 (dry-run? (assoc-ref opts 'dry-run?)))
290 (((derivations _ ...) ...)
292 (show-what-to-build* derivations
293 #:use-substitutes? substitutes?
298 (set-build-options-from-command-line* opts)
299 (built-derivations derivations)
300 (return derivations))))))))
302 (define requisites* (store-lift requisites))
304 (define (inputs->requisites inputs)
305 "Convert INPUTS, a list of input tuples or store path strings, into a set of
306 requisite store items i.e. the union closure of all the inputs."
307 (define (input->requisites input)
311 (derivation->output-path drv output))
313 (derivation->output-path drv))
314 ((? direct-store-path? path)
317 (mlet %store-monad ((reqs (sequence %store-monad
318 (map input->requisites inputs))))
319 (return (delete-duplicates (concatenate reqs)))))
321 (define exit/status (compose exit status:exit-val))
322 (define primitive-exit/status (compose primitive-exit status:exit-val))
324 (define (launch-environment command inputs paths pure?)
325 "Run COMMAND in a new environment containing INPUTS, using the native search
326 paths defined by the list PATHS. When PURE?, pre-existing environment
327 variables are cleared before setting the new ones."
328 (create-environment inputs paths pure?)
329 (apply system* command))
331 (define* (launch-environment/container #:key command bash user-mappings
332 inputs paths network?)
333 "Run COMMAND within a Linux container. The environment features INPUTS, a
334 list of derivations to be shared from the host system. Environment variables
335 are set according to PATHS, a list of native search paths. The global shell
336 is BASH, a file name for a GNU Bash binary in the store. When NETWORK?,
337 access to the host system network is permitted. USER-MAPPINGS, a list of file
338 system mappings, contains the user-specified host file systems to mount inside
340 (mlet %store-monad ((reqs (inputs->requisites
341 (cons (direct-store-path bash) inputs))))
343 (let* ((cwd (getcwd))
344 ;; Bind-mount all requisite store items, user-specified mappings,
345 ;; /bin/sh, the current working directory, and possibly networking
346 ;; configuration files within the container.
348 (append user-mappings
349 ;; Current working directory.
350 (list (file-system-mapping
354 ;; When in Rome, do as Nix build.cc does: Automagically
355 ;; map common network configuration files.
357 (filter-map (lambda (file)
358 (and (file-exists? file)
363 %network-configuration-files)
365 ;; Mappings for the union closure of all inputs.
372 (file-systems (append %container-file-systems
373 (map mapping->file-system mappings))))
375 (call-with-container (map file-system->spec file-systems)
377 ;; Setup global shell.
379 (symlink bash "/bin/sh")
381 ;; Setup directory for temporary files.
383 (for-each (lambda (var)
385 ;; The same variables as in Nix's 'build.cc'.
386 '("TMPDIR" "TEMPDIR" "TMP" "TEMP"))
388 ;; From Nix build.cc:
390 ;; Set HOME to a non-existing path to prevent certain
391 ;; programs from using /etc/passwd (or NIS, or whatever)
392 ;; to locate the home directory (for example, wget looks
393 ;; for ~/.wgetrc). I.e., these tools use /etc/passwd if
394 ;; HOME is not set, but they will just assume that the
395 ;; settings file they are looking for does not exist if
396 ;; HOME is set but points to some non-existing path.
397 (setenv "HOME" "/homeless-shelter")
399 ;; For convenience, start in the user's current working
400 ;; directory rather than the root directory.
403 (primitive-exit/status
404 ;; A container's environment is already purified, so no need to
405 ;; request it be purified again.
406 (launch-environment command inputs paths #f)))
407 #:namespaces (if network?
408 (delq 'net %namespaces) ; share host network
411 (define (environment-bash container? bootstrap? system)
412 "Return a monadic value in the store monad for the version of GNU Bash
413 needed in the environment for SYSTEM, if any. If CONTAINER? is #f, return #f.
414 If CONTAINER? and BOOTSTRAP?, return the store path for the bootstrap Bash.
415 Otherwise, return the derivation for the Bash package."
416 (with-monad %store-monad
418 ((and container? (not bootstrap?))
419 (package->derivation bash))
420 ;; Use the bootstrap Bash instead.
421 ((and container? bootstrap?)
423 (search-bootstrap-binary "bash" system)))
427 (define (parse-args args)
428 "Parse the list of command line arguments ARGS."
429 (define (handle-argument arg result)
430 (alist-cons 'package (tag-package-arg result arg) result))
432 ;; The '--' token is used to separate the command to run from the rest of
434 (let-values (((args command) (split args "--")))
435 (let ((opts (parse-command-line args %options (list %default-options)
436 #:argument-handler handle-argument)))
439 (alist-cons 'exec command opts)))))
442 (define (guix-environment . args)
444 (let* ((opts (parse-args args))
445 (pure? (assoc-ref opts 'pure))
446 (container? (assoc-ref opts 'container?))
447 (network? (assoc-ref opts 'network?))
448 (bootstrap? (assoc-ref opts 'bootstrap?))
449 (system (assoc-ref opts 'system))
450 (command (assoc-ref opts 'exec))
451 (packages (options/resolve-packages opts))
452 (mappings (pick-all opts 'file-system-mapping))
453 (inputs (delete-duplicates
454 (append-map (match-lambda
455 (('ad-hoc-package package output)
456 (package+propagated-inputs package
458 (('package package output)
459 (bag-transitive-inputs
460 (package->bag package))))
462 (paths (delete-duplicates
464 (append-map (match-lambda
465 ((label (? package? p) _ ...)
466 (package-native-search-paths p))
472 (run-with-store store
473 (mlet* %store-monad ((inputs (lower-inputs
481 ;; Containers need a Bourne shell at /bin/sh.
482 (bash (environment-bash container?
486 ;; First build the inputs. This is necessary even for
487 ;; --search-paths. Additionally, we might need to build bash
489 (build-inputs (if (derivation? bash)
490 `((,bash "out") ,@inputs)
494 ((assoc-ref opts 'dry-run?)
496 ((assoc-ref opts 'search-paths)
497 (show-search-paths inputs paths pure?)
503 (string-append (derivation->output-path bash)
505 (launch-environment/container #:command command
507 #:user-mappings mappings
510 #:network? network?)))
514 (launch-environment command inputs paths pure?))))))))))))