Commit | Line | Data |
---|---|---|
372c4bbc DT |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2014 David Thompson <davet@gnu.org> | |
3 | ;;; | |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (define-module (guix scripts environment) | |
20 | #:use-module (guix ui) | |
21 | #:use-module (guix store) | |
22 | #:use-module (guix derivations) | |
23 | #:use-module (guix packages) | |
24 | #:use-module (guix profiles) | |
099a2c70 | 25 | #:use-module (guix search-paths) |
372c4bbc DT |
26 | #:use-module (guix utils) |
27 | #:use-module (guix monads) | |
28 | #:use-module (guix build utils) | |
29 | #:use-module (guix scripts build) | |
30 | #:use-module (gnu packages) | |
31 | #:use-module (ice-9 format) | |
32 | #:use-module (ice-9 match) | |
33 | #:use-module (srfi srfi-1) | |
34 | #:use-module (srfi srfi-26) | |
35 | #:use-module (srfi srfi-37) | |
36 | #:use-module (srfi srfi-98) | |
37 | #:export (guix-environment)) | |
38 | ||
39 | (define (for-each-search-path proc inputs derivations pure?) | |
40 | "Apply PROC for each native search path in INPUTS in addition to 'PATH'. | |
41 | Use the output paths of DERIVATIONS to build each search path. When PURE? is | |
42 | #t, the existing search path value is ignored. Otherwise, the existing search | |
43 | path value is appended." | |
4b7ad2e3 DT |
44 | (let ((paths (append-map (lambda (drv) |
45 | (map (match-lambda | |
46 | ((_ . output) | |
47 | (derivation-output-path output))) | |
48 | (derivation-outputs drv))) | |
49 | derivations))) | |
372c4bbc DT |
50 | (for-each (match-lambda |
51 | (($ <search-path-specification> | |
52 | variable directories separator) | |
53 | (let* ((current (getenv variable)) | |
bd2fc4d8 LC |
54 | (path (search-path-as-list directories paths)) |
55 | (value (list->search-path-as-string path separator))) | |
372c4bbc DT |
56 | (proc variable |
57 | (if (and current (not pure?)) | |
58 | (string-append value separator current) | |
59 | value))))) | |
fdfa753c | 60 | (cons* $PATH |
372c4bbc DT |
61 | (delete-duplicates |
62 | (append-map package-native-search-paths inputs)))))) | |
63 | ||
64 | ;; Protect some env vars from purification. Borrowed from nix-shell. | |
65 | (define %precious-variables | |
66 | '("HOME" "USER" "LOGNAME" "DISPLAY" "TERM" "TZ" "PAGER")) | |
67 | ||
68 | (define (purify-environment) | |
69 | "Unset almost all environment variables. A small number of variables such | |
70 | as 'HOME' and 'USER' are left untouched." | |
71 | (for-each unsetenv | |
72 | (remove (cut member <> %precious-variables) | |
73 | (match (get-environment-variables) | |
74 | (((names . _) ...) | |
75 | names))))) | |
76 | ||
77 | (define (create-environment inputs derivations pure?) | |
78 | "Set the needed environment variables for all packages within INPUTS. When | |
79 | PURE? is #t, unset the variables in the current environment. Otherwise, | |
80 | augment existing enviroment variables with additional search paths." | |
81 | (when pure? (purify-environment)) | |
82 | (for-each-search-path setenv inputs derivations pure?)) | |
83 | ||
84 | (define (show-search-paths inputs derivations pure?) | |
85 | "Display the needed search paths to build an environment that contains the | |
86 | packages within INPUTS. When PURE? is #t, do not augment existing environment | |
87 | variables with additional search paths." | |
88 | (for-each-search-path (lambda (variable value) | |
89 | (format #t "export ~a=\"~a\"~%" variable value)) | |
90 | inputs derivations pure?)) | |
91 | ||
92 | (define (show-help) | |
93 | (display (_ "Usage: guix environment [OPTION]... PACKAGE... | |
94 | Build an environment that includes the dependencies of PACKAGE and execute a | |
95 | shell command in that environment.\n")) | |
96 | (display (_ " | |
97 | -e, --expression=EXPR create environment for the package that EXPR | |
98 | evaluates to")) | |
99 | (display (_ " | |
100 | -l, --load=FILE create environment for the package that the code within | |
101 | FILE evaluates to")) | |
102 | (display (_ " | |
103 | -E, --exec=COMMAND execute COMMAND in new environment")) | |
104 | (display (_ " | |
b9113adf | 105 | --pure unset existing environment variables")) |
372c4bbc | 106 | (display (_ " |
b9113adf | 107 | --search-paths display needed environment variable definitions")) |
372c4bbc DT |
108 | (newline) |
109 | (show-build-options-help) | |
110 | (newline) | |
111 | (display (_ " | |
112 | -h, --help display this help and exit")) | |
113 | (display (_ " | |
114 | -V, --version display version information and exit")) | |
b9113adf | 115 | (newline) |
372c4bbc DT |
116 | (show-bug-report-information)) |
117 | ||
118 | (define %default-options | |
119 | ;; Default to opening a new shell. | |
120 | `((exec . ,(or (getenv "SHELL") "/bin/sh")) | |
121 | (substitutes? . #t) | |
122 | (max-silent-time . 3600) | |
123 | (verbosity . 0))) | |
124 | ||
125 | (define %options | |
126 | ;; Specification of the command-line options. | |
127 | (cons* (option '(#\h "help") #f #f | |
128 | (lambda args | |
129 | (show-help) | |
130 | (exit 0))) | |
131 | (option '(#\V "version") #f #f | |
132 | (lambda args | |
133 | (show-version-and-exit "guix environment"))) | |
134 | (option '("pure") #f #f | |
135 | (lambda (opt name arg result) | |
136 | (alist-cons 'pure #t result))) | |
137 | (option '(#\E "exec") #t #f | |
138 | (lambda (opt name arg result) | |
139 | (alist-cons 'exec arg result))) | |
140 | (option '("search-paths") #f #f | |
141 | (lambda (opt name arg result) | |
142 | (alist-cons 'search-paths #t result))) | |
143 | (option '(#\l "load") #t #f | |
144 | (lambda (opt name arg result) | |
145 | (alist-cons 'load arg result))) | |
146 | (option '(#\e "expression") #t #f | |
147 | (lambda (opt name arg result) | |
148 | (alist-cons 'expression arg result))) | |
149 | (option '(#\n "dry-run") #f #f | |
150 | (lambda (opt name arg result) | |
151 | (alist-cons 'dry-run? #t result))) | |
152 | %standard-build-options)) | |
153 | ||
154 | (define (pick-all alist key) | |
155 | "Return a list of values in ALIST associated with KEY." | |
156 | (define same-key? (cut eq? key <>)) | |
157 | ||
158 | (fold (lambda (pair memo) | |
159 | (match pair | |
160 | (((? same-key? k) . v) | |
161 | (cons v memo)) | |
162 | (_ memo))) | |
163 | '() alist)) | |
164 | ||
165 | (define (options/resolve-packages opts) | |
166 | "Return OPTS with package specification strings replaced by actual | |
167 | packages." | |
168 | (map (match-lambda | |
169 | (('package . (? string? spec)) | |
170 | `(package . ,(specification->package spec))) | |
171 | (('expression . str) | |
172 | (match (read/eval str) | |
173 | ((? package? p) | |
174 | `(package . ,p)))) | |
175 | (('load . file) | |
176 | `(package . ,(load (string-append (getcwd) "/" file)))) | |
177 | (opt opt)) | |
178 | opts)) | |
179 | ||
180 | (define (packages->transitive-inputs packages) | |
181 | "Return a list of the transitive inputs for all PACKAGES." | |
182 | (define (transitive-inputs package) | |
183 | (filter-map (match-lambda | |
4b7ad2e3 DT |
184 | ((or (_ (? package? package)) |
185 | (_ (? package? package) _)) | |
186 | package) | |
372c4bbc DT |
187 | (_ #f)) |
188 | (bag-transitive-inputs | |
189 | (package->bag package)))) | |
190 | (delete-duplicates | |
191 | (append-map transitive-inputs packages))) | |
192 | ||
193 | ;; TODO: Deduplicate these. | |
194 | (define show-what-to-build* | |
195 | (store-lift show-what-to-build)) | |
196 | ||
197 | (define set-build-options-from-command-line* | |
198 | (store-lift set-build-options-from-command-line)) | |
199 | ||
200 | (define (build-inputs inputs opts) | |
201 | "Build the packages in INPUTS using the build options in OPTS." | |
202 | (let ((substitutes? (assoc-ref opts 'substitutes?)) | |
203 | (dry-run? (assoc-ref opts 'dry-run?))) | |
204 | (mlet* %store-monad ((drvs (sequence %store-monad | |
205 | (map package->derivation inputs)))) | |
206 | (mbegin %store-monad | |
207 | (show-what-to-build* drvs | |
208 | #:use-substitutes? substitutes? | |
209 | #:dry-run? dry-run?) | |
210 | (if dry-run? | |
211 | (return #f) | |
212 | (mbegin %store-monad | |
213 | (set-build-options-from-command-line* opts) | |
214 | (built-derivations drvs) | |
215 | (return drvs))))))) | |
216 | ||
217 | ;; Entry point. | |
218 | (define (guix-environment . args) | |
b3f21389 LC |
219 | (define (handle-argument arg result) |
220 | (alist-cons 'package arg result)) | |
372c4bbc | 221 | |
5762f306 DT |
222 | (with-error-handling |
223 | (with-store store | |
224 | (let* ((opts (parse-command-line args %options (list %default-options) | |
225 | #:argument-handler handle-argument)) | |
226 | (pure? (assoc-ref opts 'pure)) | |
227 | (command (assoc-ref opts 'exec)) | |
228 | (inputs (packages->transitive-inputs | |
229 | (pick-all (options/resolve-packages opts) 'package))) | |
230 | (drvs (run-with-store store | |
231 | (mbegin %store-monad | |
232 | (set-guile-for-build (default-guile)) | |
233 | (build-inputs inputs opts))))) | |
234 | (cond ((assoc-ref opts 'dry-run?) | |
235 | #t) | |
236 | ((assoc-ref opts 'search-paths) | |
237 | (show-search-paths inputs drvs pure?)) | |
238 | (else | |
239 | (create-environment inputs drvs pure?) | |
240 | (system command))))))) |