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