Commit | Line | Data |
---|---|---|
233e7676 | 1 | ;;; GNU Guix --- Functional package management for GNU |
db5a9444 | 2 | ;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> |
24e262f0 | 3 | ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> |
d5f01e48 | 4 | ;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org> |
6caa4dfa | 5 | ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> |
0afdc485 | 6 | ;;; |
233e7676 | 7 | ;;; This file is part of GNU Guix. |
0afdc485 | 8 | ;;; |
233e7676 | 9 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
0afdc485 LC |
10 | ;;; under the terms of the GNU General Public License as published by |
11 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
12 | ;;; your option) any later version. | |
13 | ;;; | |
233e7676 | 14 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
0afdc485 LC |
15 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
16 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | ;;; GNU General Public License for more details. | |
18 | ;;; | |
19 | ;;; You should have received a copy of the GNU General Public License | |
233e7676 | 20 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
0afdc485 | 21 | |
e49951eb | 22 | (define-module (guix scripts package) |
cdd5d6f9 | 23 | #:use-module (guix ui) |
0afdc485 | 24 | #:use-module (guix store) |
7573d30f | 25 | #:use-module (guix grafts) |
0afdc485 LC |
26 | #:use-module (guix derivations) |
27 | #:use-module (guix packages) | |
cc4ecc2d | 28 | #:use-module (guix profiles) |
e89431bf | 29 | #:use-module (guix search-paths) |
a54c94a4 | 30 | #:use-module (guix monads) |
0afdc485 | 31 | #:use-module (guix utils) |
a020d2a9 | 32 | #:use-module (guix config) |
88981dd3 | 33 | #:use-module (guix scripts) |
dd67b429 | 34 | #:use-module (guix scripts build) |
cc9a5c14 | 35 | #:use-module ((guix build utils) |
cc3de1da | 36 | #:select (directory-exists? mkdir-p)) |
0afdc485 LC |
37 | #:use-module (ice-9 format) |
38 | #:use-module (ice-9 match) | |
dc5669cd | 39 | #:use-module (ice-9 vlist) |
0afdc485 LC |
40 | #:use-module (srfi srfi-1) |
41 | #:use-module (srfi srfi-11) | |
42 | #:use-module (srfi srfi-26) | |
c0c018f1 AK |
43 | #:use-module (srfi srfi-34) |
44 | #:use-module (srfi srfi-35) | |
0afdc485 | 45 | #:use-module (srfi srfi-37) |
59a43334 | 46 | #:use-module (gnu packages) |
cc3de1da LC |
47 | #:autoload (gnu packages base) (canonical-package) |
48 | #:autoload (gnu packages guile) (guile-2.0) | |
49 | #:autoload (gnu packages bootstrap) (%bootstrap-guile) | |
5f292845 AK |
50 | #:export (build-and-use-profile |
51 | delete-generations | |
307153c1 | 52 | display-search-paths |
760c60d6 | 53 | guix-package)) |
0afdc485 | 54 | |
0afdc485 | 55 | (define %store |
c4d64534 | 56 | (make-parameter #f)) |
0afdc485 LC |
57 | |
58 | \f | |
59 | ;;; | |
cc4ecc2d | 60 | ;;; Profiles. |
0afdc485 LC |
61 | ;;; |
62 | ||
d595e456 | 63 | (define %user-profile-directory |
0afdc485 LC |
64 | (and=> (getenv "HOME") |
65 | (cut string-append <> "/.guix-profile"))) | |
66 | ||
67 | (define %profile-directory | |
80d0447c | 68 | (string-append %state-directory "/profiles/" |
6879fe23 TUBK |
69 | (or (and=> (or (getenv "USER") |
70 | (getenv "LOGNAME")) | |
0afdc485 LC |
71 | (cut string-append "per-user/" <>)) |
72 | "default"))) | |
73 | ||
74 | (define %current-profile | |
4aa52039 LC |
75 | ;; Call it `guix-profile', not `profile', to allow Guix profiles to |
76 | ;; coexist with Nix profiles. | |
77 | (string-append %profile-directory "/guix-profile")) | |
0afdc485 | 78 | |
88371f0d LC |
79 | (define (canonicalize-profile profile) |
80 | "If PROFILE is %USER-PROFILE-DIRECTORY, return %CURRENT-PROFILE. Otherwise | |
81 | return PROFILE unchanged. The goal is to treat '-p ~/.guix-profile' as if | |
82 | '-p' was omitted." ; see <http://bugs.gnu.org/17939> | |
83 | (if (and %user-profile-directory | |
84 | (string=? (canonicalize-path (dirname profile)) | |
85 | (dirname %user-profile-directory)) | |
86 | (string=? (basename profile) (basename %user-profile-directory))) | |
87 | %current-profile | |
88 | profile)) | |
89 | ||
3badccaa LC |
90 | (define (user-friendly-profile profile) |
91 | "Return either ~/.guix-profile if that's what PROFILE refers to, directly or | |
92 | indirectly, or PROFILE." | |
93 | (if (and %user-profile-directory | |
94 | (false-if-exception | |
95 | (string=? (readlink %user-profile-directory) profile))) | |
96 | %user-profile-directory | |
97 | profile)) | |
98 | ||
2cc10077 LC |
99 | (define (ensure-default-profile) |
100 | "Ensure the default profile symlink and directory exist and are writable." | |
101 | ||
102 | (define (rtfm) | |
103 | (format (current-error-port) | |
104 | (_ "Try \"info '(guix) Invoking guix package'\" for \ | |
105 | more information.~%")) | |
106 | (exit 1)) | |
107 | ||
108 | ;; Create ~/.guix-profile if it doesn't exist yet. | |
109 | (when (and %user-profile-directory | |
110 | %current-profile | |
111 | (not (false-if-exception | |
112 | (lstat %user-profile-directory)))) | |
113 | (symlink %current-profile %user-profile-directory)) | |
114 | ||
115 | (let ((s (stat %profile-directory #f))) | |
116 | ;; Attempt to create /…/profiles/per-user/$USER if needed. | |
117 | (unless (and s (eq? 'directory (stat:type s))) | |
118 | (catch 'system-error | |
119 | (lambda () | |
120 | (mkdir-p %profile-directory)) | |
121 | (lambda args | |
122 | ;; Often, we cannot create %PROFILE-DIRECTORY because its | |
123 | ;; parent directory is root-owned and we're running | |
124 | ;; unprivileged. | |
125 | (format (current-error-port) | |
126 | (_ "error: while creating directory `~a': ~a~%") | |
127 | %profile-directory | |
128 | (strerror (system-error-errno args))) | |
129 | (format (current-error-port) | |
130 | (_ "Please create the `~a' directory, with you as the owner.~%") | |
131 | %profile-directory) | |
132 | (rtfm)))) | |
133 | ||
134 | ;; Bail out if it's not owned by the user. | |
135 | (unless (or (not s) (= (stat:uid s) (getuid))) | |
136 | (format (current-error-port) | |
137 | (_ "error: directory `~a' is not owned by you~%") | |
138 | %profile-directory) | |
139 | (format (current-error-port) | |
140 | (_ "Please change the owner of `~a' to user ~s.~%") | |
141 | %profile-directory (or (getenv "USER") | |
142 | (getenv "LOGNAME") | |
143 | (getuid))) | |
144 | (rtfm)))) | |
145 | ||
b72a312c AK |
146 | (define (delete-generations store profile generations) |
147 | "Delete GENERATIONS from PROFILE. | |
148 | GENERATIONS is a list of generation numbers." | |
06d45f45 | 149 | (for-each (cut delete-generation* store profile <>) |
b72a312c AK |
150 | generations)) |
151 | ||
65d428d8 LC |
152 | (define (delete-matching-generations store profile pattern) |
153 | "Delete from PROFILE all the generations matching PATTERN. PATTERN must be | |
154 | a string denoting a set of generations: the empty list means \"all generations | |
155 | but the current one\", a number designates a generation, and other patterns | |
38fa30eb | 156 | denote ranges as interpreted by 'matching-generations'." |
65d428d8 LC |
157 | (let ((current (generation-number profile))) |
158 | (cond ((not (file-exists? profile)) ; XXX: race condition | |
159 | (raise (condition (&profile-not-found-error | |
160 | (profile profile))))) | |
161 | ((string-null? pattern) | |
0993f942 | 162 | (delete-generations store profile |
65d428d8 LC |
163 | (delv current (profile-generations profile)))) |
164 | ;; Do not delete the zeroth generation. | |
165 | ((equal? 0 (string->number pattern)) | |
250bc998 | 166 | #t) |
65d428d8 LC |
167 | |
168 | ;; If PATTERN is a duration, match generations that are | |
169 | ;; older than the specified duration. | |
170 | ((matching-generations pattern profile | |
171 | #:duration-relation >) | |
172 | => | |
173 | (lambda (numbers) | |
d26eb84d LC |
174 | (when (memv current numbers) |
175 | (warning (_ "not removing generation ~a, which is current~%") | |
176 | current)) | |
177 | ||
178 | ;; Make sure we don't inadvertently remove the current | |
179 | ;; generation. | |
180 | (let ((numbers (delv current numbers))) | |
250bc998 LC |
181 | (when (null-list? numbers) |
182 | (leave (_ "no matching generation~%"))) | |
0993f942 | 183 | (delete-generations store profile numbers)))) |
65d428d8 LC |
184 | (else |
185 | (leave (_ "invalid syntax: ~a~%") pattern))))) | |
186 | ||
d1ac5c07 LC |
187 | (define* (build-and-use-profile store profile manifest |
188 | #:key | |
189 | bootstrap? use-substitutes? | |
190 | dry-run?) | |
191 | "Build a new generation of PROFILE, a file name, using the packages | |
192 | specified in MANIFEST, a manifest object." | |
193 | (when (equal? profile %current-profile) | |
194 | (ensure-default-profile)) | |
195 | ||
196 | (let* ((prof-drv (run-with-store store | |
197 | (profile-derivation manifest | |
198 | #:hooks (if bootstrap? | |
199 | '() | |
200 | %default-profile-hooks)))) | |
201 | (prof (derivation->output-path prof-drv))) | |
202 | (show-what-to-build store (list prof-drv) | |
203 | #:use-substitutes? use-substitutes? | |
204 | #:dry-run? dry-run?) | |
205 | ||
206 | (cond | |
207 | (dry-run? #t) | |
208 | ((and (file-exists? profile) | |
209 | (and=> (readlink* profile) (cut string=? prof <>))) | |
210 | (format (current-error-port) (_ "nothing to be done~%"))) | |
211 | (else | |
212 | (let* ((number (generation-number profile)) | |
213 | ||
214 | ;; Always use NUMBER + 1 for the new profile, possibly | |
215 | ;; overwriting a "previous future generation". | |
216 | (name (generation-file-name profile (+ 1 number)))) | |
217 | (and (build-derivations store (list prof-drv)) | |
218 | (let* ((entries (manifest-entries manifest)) | |
219 | (count (length entries))) | |
220 | (switch-symlinks name prof) | |
221 | (switch-symlinks profile name) | |
222 | (unless (string=? profile %current-profile) | |
223 | (register-gc-root store name)) | |
224 | (format #t (N_ "~a package in profile~%" | |
225 | "~a packages in profile~%" | |
226 | count) | |
227 | count) | |
4e3bfaf4 LC |
228 | (display-search-paths entries (list profile) |
229 | #:kind 'prefix)))))))) | |
d1ac5c07 | 230 | |
cc4ecc2d LC |
231 | \f |
232 | ;;; | |
233 | ;;; Package specifications. | |
234 | ;;; | |
235 | ||
db5a9444 LC |
236 | (define (find-packages-by-description regexps) |
237 | "Return the list of packages whose name matches one of REGEXPS, or whose | |
238 | synopsis or description matches all of REGEXPS." | |
051edc95 LC |
239 | (define version<? (negate version>=?)) |
240 | ||
db5a9444 LC |
241 | (define (matches-all? str) |
242 | (every (cut regexp-exec <> str) regexps)) | |
243 | ||
244 | (define (matches-one? str) | |
245 | (find (cut regexp-exec <> str) regexps)) | |
246 | ||
9eeb3d8c LC |
247 | (sort |
248 | (fold-packages (lambda (package result) | |
db5a9444 | 249 | (if (or (matches-one? (package-name package)) |
9eeb3d8c | 250 | (and=> (package-synopsis package) |
db5a9444 | 251 | (compose matches-all? P_)) |
9eeb3d8c | 252 | (and=> (package-description package) |
db5a9444 | 253 | (compose matches-all? P_))) |
9eeb3d8c LC |
254 | (cons package result) |
255 | result)) | |
256 | '()) | |
257 | (lambda (p1 p2) | |
051edc95 LC |
258 | (case (string-compare (package-name p1) (package-name p2) |
259 | (const '<) (const '=) (const '>)) | |
260 | ((=) (version<? (package-version p1) (package-version p2))) | |
261 | ((<) #t) | |
262 | (else #f))))) | |
acc08466 | 263 | |
5239f3d9 LC |
264 | (define (transaction-upgrade-entry entry transaction) |
265 | "Return a variant of TRANSACTION that accounts for the upgrade of ENTRY, a | |
266 | <manifest-entry>." | |
01afdab8 LC |
267 | (define (supersede old new) |
268 | (info (_ "package '~a' has been superseded by '~a'~%") | |
269 | (manifest-entry-name old) (package-name new)) | |
270 | (manifest-transaction-install-entry | |
271 | (package->manifest-entry new (manifest-entry-output old)) | |
272 | (manifest-transaction-remove-pattern | |
273 | (manifest-pattern | |
274 | (name (manifest-entry-name old)) | |
275 | (version (manifest-entry-version old)) | |
276 | (output (manifest-entry-output old))) | |
277 | transaction))) | |
278 | ||
dd721734 LC |
279 | (match entry |
280 | (($ <manifest-entry> name version output (? string? path)) | |
281 | (match (vhash-assoc name (find-newest-available-packages)) | |
282 | ((_ candidate-version pkg . rest) | |
01afdab8 LC |
283 | (match (package-superseded pkg) |
284 | ((? package? new) | |
285 | (supersede entry new)) | |
286 | (#f | |
287 | (case (version-compare candidate-version version) | |
288 | ((>) | |
289 | (manifest-transaction-install-entry | |
290 | (package->manifest-entry pkg output) | |
291 | transaction)) | |
292 | ((<) | |
293 | transaction) | |
294 | ((=) | |
295 | (let ((candidate-path (derivation->output-path | |
296 | (package-derivation (%store) pkg)))) | |
297 | (if (string=? path candidate-path) | |
298 | transaction | |
299 | (manifest-transaction-install-entry | |
300 | (package->manifest-entry pkg output) | |
301 | transaction)))))))) | |
dd721734 | 302 | (#f |
5239f3d9 | 303 | transaction))))) |
d46d8794 | 304 | |
d46d8794 LC |
305 | \f |
306 | ;;; | |
307 | ;;; Search paths. | |
308 | ;;; | |
309 | ||
fc2d2339 | 310 | (define* (search-path-environment-variables entries profiles |
dbc31ab2 LC |
311 | #:optional (getenv getenv) |
312 | #:key (kind 'exact)) | |
4e9f5920 | 313 | "Return environment variable definitions that may be needed for the use of |
fc2d2339 | 314 | ENTRIES, a list of manifest entries, in PROFILES. Use GETENV to determine the |
dbc31ab2 LC |
315 | current settings and report only settings not already effective. KIND |
316 | must be one of 'exact, 'prefix, or 'suffix, depending on the kind of search | |
317 | path definition to be returned." | |
3badccaa | 318 | (let ((search-paths (delete-duplicates |
755e1147 LC |
319 | (cons $PATH |
320 | (append-map manifest-entry-search-paths | |
321 | entries))))) | |
4e9f5920 | 322 | (filter-map (match-lambda |
441cfb42 LC |
323 | ((spec . value) |
324 | (let ((variable (search-path-specification-variable spec)) | |
325 | (sep (search-path-specification-separator spec))) | |
441cfb42 | 326 | (environment-variable-definition variable value |
dbc31ab2 LC |
327 | #:separator sep |
328 | #:kind kind)))) | |
fc2d2339 | 329 | (evaluate-search-paths search-paths profiles |
36914999 | 330 | getenv)))) |
5924080d | 331 | |
fc2d2339 | 332 | (define* (display-search-paths entries profiles |
dbc31ab2 | 333 | #:key (kind 'exact)) |
5924080d | 334 | "Display the search path environment variables that may need to be set for |
f067fc3e | 335 | ENTRIES, a list of manifest entries, in the context of PROFILE." |
fc2d2339 LC |
336 | (let* ((profiles (map user-friendly-profile profiles)) |
337 | (settings (search-path-environment-variables entries profiles | |
dbc31ab2 | 338 | #:kind kind))) |
5924080d LC |
339 | (unless (null? settings) |
340 | (format #t (_ "The following environment variable definitions may be needed:~%")) | |
a81bc531 | 341 | (format #t "~{ ~a~%~}" settings)))) |
5924080d | 342 | |
0afdc485 LC |
343 | \f |
344 | ;;; | |
345 | ;;; Command-line options. | |
346 | ;;; | |
347 | ||
348 | (define %default-options | |
349 | ;; Alist of default option values. | |
fc2d2339 | 350 | `((max-silent-time . 3600) |
dd67b429 | 351 | (verbosity . 0) |
7573d30f | 352 | (graft? . #t) |
3b824605 | 353 | (substitutes? . #t))) |
0afdc485 | 354 | |
0afdc485 | 355 | (define (show-help) |
2a4e2e4b AK |
356 | (display (_ "Usage: guix package [OPTION]... |
357 | Install, remove, or upgrade packages in a single transaction.\n")) | |
0afdc485 | 358 | (display (_ " |
2a4e2e4b AK |
359 | -i, --install PACKAGE ... |
360 | install PACKAGEs")) | |
0afdc485 | 361 | (display (_ " |
5d4b411f LC |
362 | -e, --install-from-expression=EXP |
363 | install the package EXP evaluates to")) | |
364 | (display (_ " | |
0d279400 DT |
365 | -f, --install-from-file=FILE |
366 | install the package that the code within FILE | |
367 | evaluates to")) | |
368 | (display (_ " | |
2a4e2e4b AK |
369 | -r, --remove PACKAGE ... |
370 | remove PACKAGEs")) | |
0afdc485 | 371 | (display (_ " |
acb6ba25 | 372 | -u, --upgrade[=REGEXP] upgrade all the installed packages matching REGEXP")) |
1b676447 DT |
373 | (display (_ " |
374 | -m, --manifest=FILE create a new profile generation with the manifest | |
375 | from FILE")) | |
d5f01e48 MW |
376 | (display (_ " |
377 | --do-not-upgrade[=REGEXP] do not upgrade any packages matching REGEXP")) | |
24e262f0 LC |
378 | (display (_ " |
379 | --roll-back roll back to the previous generation")) | |
5924080d | 380 | (display (_ " |
a4b1a6b6 LC |
381 | --search-paths[=KIND] |
382 | display needed environment variable definitions")) | |
2cd09108 NK |
383 | (display (_ " |
384 | -l, --list-generations[=PATTERN] | |
385 | list generations matching PATTERN")) | |
b7884ca3 NK |
386 | (display (_ " |
387 | -d, --delete-generations[=PATTERN] | |
388 | delete generations matching PATTERN")) | |
0afdc485 | 389 | (display (_ " |
b3bb82f1 AK |
390 | -S, --switch-generation=PATTERN |
391 | switch to a generation matching PATTERN")) | |
392 | (display (_ " | |
0afdc485 | 393 | -p, --profile=PROFILE use PROFILE instead of the user's default profile")) |
dd67b429 | 394 | (newline) |
0afdc485 | 395 | (display (_ " |
cc57f25d | 396 | --bootstrap use the bootstrap Guile to build the profile")) |
70915c1a LC |
397 | (display (_ " |
398 | --verbose produce verbose output")) | |
0afdc485 LC |
399 | (newline) |
400 | (display (_ " | |
acc08466 NK |
401 | -s, --search=REGEXP search in synopsis and description using REGEXP")) |
402 | (display (_ " | |
733b4130 LC |
403 | -I, --list-installed[=REGEXP] |
404 | list installed packages matching REGEXP")) | |
64fc89b6 LC |
405 | (display (_ " |
406 | -A, --list-available[=REGEXP] | |
407 | list available packages matching REGEXP")) | |
2aa6efb0 | 408 | (display (_ " |
d2aa1225 | 409 | --show=PACKAGE show details about PACKAGE")) |
733b4130 | 410 | (newline) |
dd67b429 LC |
411 | (show-build-options-help) |
412 | (newline) | |
b8638f03 LC |
413 | (show-transformation-options-help) |
414 | (newline) | |
733b4130 | 415 | (display (_ " |
0afdc485 LC |
416 | -h, --help display this help and exit")) |
417 | (display (_ " | |
418 | -V, --version display version information and exit")) | |
419 | (newline) | |
3441e164 | 420 | (show-bug-report-information)) |
0afdc485 LC |
421 | |
422 | (define %options | |
423 | ;; Specification of the command-line options. | |
dd67b429 LC |
424 | (cons* (option '(#\h "help") #f #f |
425 | (lambda args | |
426 | (show-help) | |
427 | (exit 0))) | |
428 | (option '(#\V "version") #f #f | |
429 | (lambda args | |
430 | (show-version-and-exit "guix package"))) | |
431 | ||
432 | (option '(#\i "install") #f #t | |
433 | (lambda (opt name arg result arg-handler) | |
434 | (let arg-handler ((arg arg) (result result)) | |
435 | (values (if arg | |
436 | (alist-cons 'install arg result) | |
437 | result) | |
438 | arg-handler)))) | |
439 | (option '(#\e "install-from-expression") #t #f | |
440 | (lambda (opt name arg result arg-handler) | |
441 | (values (alist-cons 'install (read/eval-package-expression arg) | |
442 | result) | |
443 | #f))) | |
0d279400 DT |
444 | (option '(#\f "install-from-file") #t #f |
445 | (lambda (opt name arg result arg-handler) | |
446 | (values (alist-cons 'install | |
447 | (load* arg (make-user-module '())) | |
448 | result) | |
449 | #f))) | |
dd67b429 LC |
450 | (option '(#\r "remove") #f #t |
451 | (lambda (opt name arg result arg-handler) | |
452 | (let arg-handler ((arg arg) (result result)) | |
453 | (values (if arg | |
454 | (alist-cons 'remove arg result) | |
455 | result) | |
456 | arg-handler)))) | |
457 | (option '(#\u "upgrade") #f #t | |
458 | (lambda (opt name arg result arg-handler) | |
459 | (let arg-handler ((arg arg) (result result)) | |
460 | (values (alist-cons 'upgrade arg | |
461 | ;; Delete any prior "upgrade all" | |
462 | ;; command, or else "--upgrade gcc" | |
463 | ;; would upgrade everything. | |
464 | (delete '(upgrade . #f) result)) | |
465 | arg-handler)))) | |
d5f01e48 MW |
466 | (option '("do-not-upgrade") #f #t |
467 | (lambda (opt name arg result arg-handler) | |
468 | (let arg-handler ((arg arg) (result result)) | |
469 | (values (if arg | |
470 | (alist-cons 'do-not-upgrade arg result) | |
471 | result) | |
472 | arg-handler)))) | |
dd67b429 LC |
473 | (option '("roll-back") #f #f |
474 | (lambda (opt name arg result arg-handler) | |
475 | (values (alist-cons 'roll-back? #t result) | |
476 | #f))) | |
1b676447 DT |
477 | (option '(#\m "manifest") #t #f |
478 | (lambda (opt name arg result arg-handler) | |
479 | (values (alist-cons 'manifest arg result) | |
480 | arg-handler))) | |
dd67b429 LC |
481 | (option '(#\l "list-generations") #f #t |
482 | (lambda (opt name arg result arg-handler) | |
483 | (values (cons `(query list-generations ,(or arg "")) | |
484 | result) | |
485 | #f))) | |
486 | (option '(#\d "delete-generations") #f #t | |
487 | (lambda (opt name arg result arg-handler) | |
488 | (values (alist-cons 'delete-generations (or arg "") | |
489 | result) | |
490 | #f))) | |
b3bb82f1 AK |
491 | (option '(#\S "switch-generation") #t #f |
492 | (lambda (opt name arg result arg-handler) | |
493 | (values (alist-cons 'switch-generation arg result) | |
494 | #f))) | |
dbc31ab2 | 495 | (option '("search-paths") #f #t |
dd67b429 | 496 | (lambda (opt name arg result arg-handler) |
dbc31ab2 LC |
497 | (let ((kind (match arg |
498 | ((or "exact" "prefix" "suffix") | |
499 | (string->symbol arg)) | |
500 | (#f | |
501 | 'exact) | |
502 | (x | |
503 | (leave (_ "~a: unsupported \ | |
504 | kind of search path~%") | |
505 | x))))) | |
506 | (values (cons `(query search-paths ,kind) | |
507 | result) | |
508 | #f)))) | |
dd67b429 LC |
509 | (option '(#\p "profile") #t #f |
510 | (lambda (opt name arg result arg-handler) | |
88371f0d | 511 | (values (alist-cons 'profile (canonicalize-profile arg) |
fc2d2339 | 512 | result) |
dd67b429 LC |
513 | #f))) |
514 | (option '(#\n "dry-run") #f #f | |
515 | (lambda (opt name arg result arg-handler) | |
fd59105c RJ |
516 | (values (alist-cons 'dry-run? #t |
517 | (alist-cons 'graft? #f result)) | |
dd67b429 LC |
518 | #f))) |
519 | (option '("bootstrap") #f #f | |
520 | (lambda (opt name arg result arg-handler) | |
521 | (values (alist-cons 'bootstrap? #t result) | |
522 | #f))) | |
523 | (option '("verbose") #f #f | |
524 | (lambda (opt name arg result arg-handler) | |
525 | (values (alist-cons 'verbose? #t result) | |
526 | #f))) | |
527 | (option '(#\s "search") #t #f | |
528 | (lambda (opt name arg result arg-handler) | |
529 | (values (cons `(query search ,(or arg "")) | |
530 | result) | |
531 | #f))) | |
532 | (option '(#\I "list-installed") #f #t | |
533 | (lambda (opt name arg result arg-handler) | |
534 | (values (cons `(query list-installed ,(or arg "")) | |
535 | result) | |
536 | #f))) | |
537 | (option '(#\A "list-available") #f #t | |
538 | (lambda (opt name arg result arg-handler) | |
539 | (values (cons `(query list-available ,(or arg "")) | |
540 | result) | |
541 | #f))) | |
2aa6efb0 CR |
542 | (option '("show") #t #t |
543 | (lambda (opt name arg result arg-handler) | |
544 | (values (cons `(query show ,arg) | |
545 | result) | |
546 | #f))) | |
dd67b429 | 547 | |
b8638f03 LC |
548 | (append %transformation-options |
549 | %standard-build-options))) | |
0afdc485 | 550 | |
27b91d78 LC |
551 | (define (options->upgrade-predicate opts) |
552 | "Return a predicate based on the upgrade/do-not-upgrade regexps in OPTS | |
553 | that, given a package name, returns true if the package is a candidate for | |
554 | upgrading, #f otherwise." | |
edac8846 LC |
555 | (define upgrade-regexps |
556 | (filter-map (match-lambda | |
27b91d78 LC |
557 | (('upgrade . regexp) |
558 | (make-regexp* (or regexp ""))) | |
559 | (_ #f)) | |
edac8846 LC |
560 | opts)) |
561 | ||
d5f01e48 MW |
562 | (define do-not-upgrade-regexps |
563 | (filter-map (match-lambda | |
27b91d78 LC |
564 | (('do-not-upgrade . regexp) |
565 | (make-regexp* regexp)) | |
566 | (_ #f)) | |
d5f01e48 MW |
567 | opts)) |
568 | ||
27b91d78 LC |
569 | (lambda (name) |
570 | (and (any (cut regexp-exec <> name) upgrade-regexps) | |
571 | (not (any (cut regexp-exec <> name) do-not-upgrade-regexps))))) | |
572 | ||
573 | (define (store-item->manifest-entry item) | |
574 | "Return a manifest entry for ITEM, a \"/gnu/store/...\" file name." | |
575 | (let-values (((name version) | |
576 | (package-name->name+version (store-path-package-name item)))) | |
577 | (manifest-entry | |
578 | (name name) | |
579 | (version version) | |
580 | (output #f) | |
581 | (item item)))) | |
582 | ||
5239f3d9 | 583 | (define (options->installable opts manifest transaction) |
27b91d78 | 584 | "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold', |
5239f3d9 LC |
585 | return an variant of TRANSACTION that accounts for the specified installations |
586 | and upgrades." | |
27b91d78 LC |
587 | (define upgrade? |
588 | (options->upgrade-predicate opts)) | |
edac8846 | 589 | |
5239f3d9 LC |
590 | (define upgraded |
591 | (fold (lambda (entry transaction) | |
592 | (if (upgrade? (manifest-entry-name entry)) | |
593 | (transaction-upgrade-entry entry transaction) | |
594 | transaction)) | |
595 | transaction | |
596 | (manifest-entries manifest))) | |
edac8846 | 597 | |
27b91d78 | 598 | (define to-install |
edac8846 | 599 | (filter-map (match-lambda |
27b91d78 LC |
600 | (('install . (? package? p)) |
601 | ;; When given a package via `-e', install the first of its | |
602 | ;; outputs (XXX). | |
6caa4dfa | 603 | (package->manifest-entry p "out")) |
27b91d78 LC |
604 | (('install . (? string? spec)) |
605 | (if (store-path? spec) | |
606 | (store-item->manifest-entry spec) | |
edac8846 LC |
607 | (let-values (((package output) |
608 | (specification->package+output spec))) | |
6caa4dfa | 609 | (package->manifest-entry package output)))) |
27b91d78 | 610 | (_ #f)) |
edac8846 LC |
611 | opts)) |
612 | ||
5239f3d9 LC |
613 | (fold manifest-transaction-install-entry |
614 | upgraded | |
615 | to-install)) | |
616 | ||
617 | (define (options->removable options manifest transaction) | |
618 | "Given options, return a variant of TRANSACTION augmented with the list of | |
619 | patterns of packages to remove." | |
620 | (fold (lambda (opt transaction) | |
621 | (match opt | |
622 | (('remove . spec) | |
623 | (call-with-values | |
624 | (lambda () | |
625 | (package-specification->name+version+output spec)) | |
626 | (lambda (name version output) | |
627 | (manifest-transaction-remove-pattern | |
628 | (manifest-pattern | |
629 | (name name) | |
630 | (version version) | |
631 | (output output)) | |
632 | transaction)))) | |
633 | (_ transaction))) | |
634 | transaction | |
635 | options)) | |
537630c5 | 636 | |
c9323a4c LC |
637 | (define (register-gc-root store profile) |
638 | "Register PROFILE, a profile generation symlink, as a GC root, unless it | |
639 | doesn't need it." | |
640 | (define absolute | |
641 | ;; We must pass the daemon an absolute file name for PROFILE. However, we | |
642 | ;; cannot use (canonicalize-path profile) because that would return us the | |
643 | ;; target of PROFILE in the store; using a store item as an indirect root | |
644 | ;; would mean that said store item will always remain live, which is not | |
645 | ;; what we want here. | |
646 | (if (string-prefix? "/" profile) | |
647 | profile | |
648 | (string-append (getcwd) "/" profile))) | |
649 | ||
650 | (add-indirect-root store absolute)) | |
d2952326 | 651 | |
59055895 LC |
652 | \f |
653 | ;;; | |
654 | ;;; Queries and actions. | |
655 | ;;; | |
656 | ||
2cc10077 LC |
657 | (define (process-query opts) |
658 | "Process any query specified by OPTS. Return #t when a query was actually | |
659 | processed, #f otherwise." | |
660 | (let* ((profiles (match (filter-map (match-lambda | |
661 | (('profile . p) p) | |
662 | (_ #f)) | |
663 | opts) | |
664 | (() (list %current-profile)) | |
665 | (lst lst))) | |
666 | (profile (match profiles | |
667 | ((head tail ...) head)))) | |
668 | (match (assoc-ref opts 'query) | |
669 | (('list-generations pattern) | |
670 | (define (list-generation number) | |
671 | (unless (zero? number) | |
672 | (display-generation profile number) | |
673 | (display-profile-content profile number) | |
674 | (newline))) | |
675 | ||
676 | (cond ((not (file-exists? profile)) ; XXX: race condition | |
677 | (raise (condition (&profile-not-found-error | |
678 | (profile profile))))) | |
679 | ((string-null? pattern) | |
680 | (for-each list-generation (profile-generations profile))) | |
681 | ((matching-generations pattern profile) | |
682 | => | |
683 | (lambda (numbers) | |
684 | (if (null-list? numbers) | |
685 | (exit 1) | |
686 | (leave-on-EPIPE | |
687 | (for-each list-generation numbers))))) | |
688 | (else | |
689 | (leave (_ "invalid syntax: ~a~%") | |
690 | pattern))) | |
691 | #t) | |
692 | ||
693 | (('list-installed regexp) | |
694 | (let* ((regexp (and regexp (make-regexp* regexp))) | |
695 | (manifest (profile-manifest profile)) | |
696 | (installed (manifest-entries manifest))) | |
697 | (leave-on-EPIPE | |
698 | (for-each (match-lambda | |
699 | (($ <manifest-entry> name version output path _) | |
700 | (when (or (not regexp) | |
701 | (regexp-exec regexp name)) | |
702 | (format #t "~a\t~a\t~a\t~a~%" | |
703 | name (or version "?") output path)))) | |
704 | ||
705 | ;; Show most recently installed packages last. | |
706 | (reverse installed))) | |
707 | #t)) | |
708 | ||
709 | (('list-available regexp) | |
710 | (let* ((regexp (and regexp (make-regexp* regexp))) | |
711 | (available (fold-packages | |
712 | (lambda (p r) | |
713 | (let ((n (package-name p))) | |
714 | (if (supported-package? p) | |
715 | (if regexp | |
716 | (if (regexp-exec regexp n) | |
717 | (cons p r) | |
718 | r) | |
719 | (cons p r)) | |
720 | r))) | |
721 | '()))) | |
722 | (leave-on-EPIPE | |
723 | (for-each (lambda (p) | |
724 | (format #t "~a\t~a\t~a\t~a~%" | |
725 | (package-name p) | |
726 | (package-version p) | |
727 | (string-join (package-outputs p) ",") | |
728 | (location->string (package-location p)))) | |
729 | (sort available | |
730 | (lambda (p1 p2) | |
731 | (string<? (package-name p1) | |
732 | (package-name p2)))))) | |
733 | #t)) | |
734 | ||
db5a9444 LC |
735 | (('search _) |
736 | (let* ((patterns (filter-map (match-lambda | |
737 | (('query 'search rx) rx) | |
738 | (_ #f)) | |
739 | opts)) | |
740 | (regexps (map (cut make-regexp* <> regexp/icase) patterns))) | |
2cc10077 LC |
741 | (leave-on-EPIPE |
742 | (for-each (cute package->recutils <> (current-output-port)) | |
db5a9444 | 743 | (find-packages-by-description regexps))) |
2cc10077 LC |
744 | #t)) |
745 | ||
746 | (('show requested-name) | |
747 | (let-values (((name version) | |
748 | (package-name->name+version requested-name))) | |
749 | (leave-on-EPIPE | |
750 | (for-each (cute package->recutils <> (current-output-port)) | |
751 | (find-packages-by-name name version))) | |
752 | #t)) | |
753 | ||
754 | (('search-paths kind) | |
755 | (let* ((manifests (map profile-manifest profiles)) | |
756 | (entries (append-map manifest-entries manifests)) | |
757 | (profiles (map user-friendly-profile profiles)) | |
758 | (settings (search-path-environment-variables entries profiles | |
759 | (const #f) | |
760 | #:kind kind))) | |
761 | (format #t "~{~a~%~}" settings) | |
762 | #t)) | |
763 | ||
764 | (_ #f)))) | |
765 | ||
59055895 LC |
766 | |
767 | (define* (roll-back-action store profile arg opts | |
768 | #:key dry-run?) | |
769 | "Roll back PROFILE to its previous generation." | |
770 | (unless dry-run? | |
771 | (roll-back* store profile))) | |
772 | ||
773 | (define* (switch-generation-action store profile spec opts | |
774 | #:key dry-run?) | |
775 | "Switch PROFILE to the generation specified by SPEC." | |
776 | (unless dry-run? | |
777 | (let* ((number (string->number spec)) | |
778 | (number (and number | |
779 | (case (string-ref spec 0) | |
780 | ((#\+ #\-) | |
781 | (relative-generation profile number)) | |
782 | (else number))))) | |
783 | (if number | |
784 | (switch-to-generation* profile number) | |
785 | (leave (_ "cannot switch to generation '~a'~%") spec))))) | |
786 | ||
787 | (define* (delete-generations-action store profile pattern opts | |
788 | #:key dry-run?) | |
789 | "Delete PROFILE's generations that match PATTERN." | |
790 | (unless dry-run? | |
791 | (delete-matching-generations store profile pattern))) | |
792 | ||
793 | (define* (manifest-action store profile file opts | |
794 | #:key dry-run?) | |
795 | "Change PROFILE to contain the packages specified in FILE." | |
796 | (let* ((user-module (make-user-module '((guix profiles) (gnu)))) | |
797 | (manifest (load* file user-module)) | |
798 | (bootstrap? (assoc-ref opts 'bootstrap?)) | |
799 | (substitutes? (assoc-ref opts 'substitutes?))) | |
800 | (if dry-run? | |
801 | (format #t (_ "would install new manifest from '~a' with ~d entries~%") | |
802 | file (length (manifest-entries manifest))) | |
803 | (format #t (_ "installing new manifest from '~a' with ~d entries~%") | |
804 | file (length (manifest-entries manifest)))) | |
805 | (build-and-use-profile store profile manifest | |
806 | #:bootstrap? bootstrap? | |
807 | #:use-substitutes? substitutes? | |
808 | #:dry-run? dry-run?))) | |
809 | ||
810 | (define %actions | |
811 | ;; List of actions that may be processed. The car of each pair is the | |
812 | ;; action's symbol in the option list; the cdr is the action's procedure. | |
813 | `((roll-back? . ,roll-back-action) | |
814 | (switch-generation . ,switch-generation-action) | |
815 | (delete-generations . ,delete-generations-action) | |
816 | (manifest . ,manifest-action))) | |
817 | ||
6e370175 LC |
818 | (define (process-actions store opts) |
819 | "Process any install/remove/upgrade action from OPTS." | |
820 | ||
821 | (define dry-run? (assoc-ref opts 'dry-run?)) | |
822 | (define bootstrap? (assoc-ref opts 'bootstrap?)) | |
823 | (define substitutes? (assoc-ref opts 'substitutes?)) | |
824 | (define profile (or (assoc-ref opts 'profile) %current-profile)) | |
b8638f03 LC |
825 | (define transform (options->transformation opts)) |
826 | ||
827 | (define (transform-entry entry) | |
494dc2fc LC |
828 | (let ((item (transform store (manifest-entry-item entry)))) |
829 | (manifest-entry | |
830 | (inherit entry) | |
831 | (item item) | |
832 | (version (if (package? item) | |
833 | (package-version item) | |
834 | (manifest-entry-version entry)))))) | |
6e370175 LC |
835 | |
836 | ;; First, process roll-backs, generation removals, etc. | |
837 | (for-each (match-lambda | |
838 | ((key . arg) | |
839 | (and=> (assoc-ref %actions key) | |
840 | (lambda (proc) | |
841 | (proc store profile arg opts | |
842 | #:dry-run? dry-run?))))) | |
843 | opts) | |
844 | ||
845 | ;; Then, process normal package installation/removal/upgrade. | |
5239f3d9 LC |
846 | (let* ((manifest (profile-manifest profile)) |
847 | (step1 (options->installable opts manifest | |
848 | (manifest-transaction))) | |
849 | (step2 (options->removable opts manifest step1)) | |
850 | (step3 (manifest-transaction | |
851 | (inherit step2) | |
852 | (install (map transform-entry | |
853 | (manifest-transaction-install step2))))) | |
854 | (new (manifest-perform-transaction manifest step3))) | |
855 | ||
856 | (unless (manifest-transaction-null? step3) | |
857 | (show-manifest-transaction store manifest step3 | |
6e370175 LC |
858 | #:dry-run? dry-run?) |
859 | (build-and-use-profile store profile new | |
860 | #:bootstrap? bootstrap? | |
861 | #:use-substitutes? substitutes? | |
862 | #:dry-run? dry-run?)))) | |
863 | ||
0afdc485 LC |
864 | \f |
865 | ;;; | |
866 | ;;; Entry point. | |
867 | ;;; | |
868 | ||
869 | (define (guix-package . args) | |
b3f21389 LC |
870 | (define (handle-argument arg result arg-handler) |
871 | ;; Process non-option argument ARG by calling back ARG-HANDLER. | |
872 | (if arg-handler | |
873 | (arg-handler arg result) | |
874 | (leave (_ "~A: extraneous argument~%") arg))) | |
0afdc485 | 875 | |
b3f21389 LC |
876 | (let ((opts (parse-command-line args %options (list %default-options #f) |
877 | #:argument-handler handle-argument))) | |
c0c018f1 AK |
878 | (with-error-handling |
879 | (or (process-query opts) | |
7573d30f LC |
880 | (parameterize ((%store (open-connection)) |
881 | (%graft? (assoc-ref opts 'graft?))) | |
dd67b429 | 882 | (set-build-options-from-command-line (%store) opts) |
3b824605 | 883 | |
c4d64534 | 884 | (parameterize ((%guile-for-build |
bdb36958 LC |
885 | (package-derivation |
886 | (%store) | |
887 | (if (assoc-ref opts 'bootstrap?) | |
888 | %bootstrap-guile | |
889 | (canonical-package guile-2.0))))) | |
6e370175 | 890 | (process-actions (%store) opts))))))) |