Commit | Line | Data |
---|---|---|
233e7676 | 1 | ;;; GNU Guix --- Functional package management for GNU |
1a096504 | 2 | ;;; Copyright © 2012, 2013, 2014, 2015 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> |
b72a312c | 5 | ;;; Copyright © 2014 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 LC |
24 | #:use-module (guix store) |
25 | #:use-module (guix derivations) | |
26 | #:use-module (guix packages) | |
cc4ecc2d | 27 | #:use-module (guix profiles) |
a54c94a4 | 28 | #:use-module (guix monads) |
0afdc485 | 29 | #:use-module (guix utils) |
a020d2a9 | 30 | #:use-module (guix config) |
dd67b429 | 31 | #:use-module (guix scripts build) |
cc9a5c14 LC |
32 | #:use-module ((guix build utils) |
33 | #:select (directory-exists? mkdir-p search-path-as-list)) | |
0afdc485 LC |
34 | #:use-module (ice-9 format) |
35 | #:use-module (ice-9 match) | |
36 | #:use-module (ice-9 regex) | |
dc5669cd | 37 | #:use-module (ice-9 vlist) |
0afdc485 LC |
38 | #:use-module (srfi srfi-1) |
39 | #:use-module (srfi srfi-11) | |
2cd09108 | 40 | #:use-module (srfi srfi-19) |
0afdc485 | 41 | #:use-module (srfi srfi-26) |
c0c018f1 AK |
42 | #:use-module (srfi srfi-34) |
43 | #:use-module (srfi srfi-35) | |
0afdc485 | 44 | #:use-module (srfi srfi-37) |
59a43334 | 45 | #:use-module (gnu packages) |
bdb36958 LC |
46 | #:use-module (gnu packages base) |
47 | #:use-module (gnu packages guile) | |
1ffa7090 | 48 | #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) |
760c60d6 | 49 | #:export (specification->package+output |
b3bb82f1 AK |
50 | switch-to-generation |
51 | switch-to-previous-generation | |
b72a312c AK |
52 | roll-back |
53 | delete-generation | |
54 | delete-generations | |
760c60d6 | 55 | guix-package)) |
0afdc485 | 56 | |
0afdc485 | 57 | (define %store |
c4d64534 | 58 | (make-parameter #f)) |
0afdc485 LC |
59 | |
60 | \f | |
61 | ;;; | |
cc4ecc2d | 62 | ;;; Profiles. |
0afdc485 LC |
63 | ;;; |
64 | ||
d595e456 | 65 | (define %user-profile-directory |
0afdc485 LC |
66 | (and=> (getenv "HOME") |
67 | (cut string-append <> "/.guix-profile"))) | |
68 | ||
69 | (define %profile-directory | |
80d0447c | 70 | (string-append %state-directory "/profiles/" |
6879fe23 TUBK |
71 | (or (and=> (or (getenv "USER") |
72 | (getenv "LOGNAME")) | |
0afdc485 LC |
73 | (cut string-append "per-user/" <>)) |
74 | "default"))) | |
75 | ||
76 | (define %current-profile | |
4aa52039 LC |
77 | ;; Call it `guix-profile', not `profile', to allow Guix profiles to |
78 | ;; coexist with Nix profiles. | |
79 | (string-append %profile-directory "/guix-profile")) | |
0afdc485 | 80 | |
88371f0d LC |
81 | (define (canonicalize-profile profile) |
82 | "If PROFILE is %USER-PROFILE-DIRECTORY, return %CURRENT-PROFILE. Otherwise | |
83 | return PROFILE unchanged. The goal is to treat '-p ~/.guix-profile' as if | |
84 | '-p' was omitted." ; see <http://bugs.gnu.org/17939> | |
85 | (if (and %user-profile-directory | |
86 | (string=? (canonicalize-path (dirname profile)) | |
87 | (dirname %user-profile-directory)) | |
88 | (string=? (basename profile) (basename %user-profile-directory))) | |
89 | %current-profile | |
90 | profile)) | |
91 | ||
3badccaa LC |
92 | (define (user-friendly-profile profile) |
93 | "Return either ~/.guix-profile if that's what PROFILE refers to, directly or | |
94 | indirectly, or PROFILE." | |
95 | (if (and %user-profile-directory | |
96 | (false-if-exception | |
97 | (string=? (readlink %user-profile-directory) profile))) | |
98 | %user-profile-directory | |
99 | profile)) | |
100 | ||
b72a312c | 101 | (define (link-to-empty-profile store generation) |
64d2e973 | 102 | "Link GENERATION, a string, to the empty profile." |
b72a312c | 103 | (let* ((drv (run-with-store store |
a54c94a4 | 104 | (profile-derivation (manifest '())))) |
64d2e973 | 105 | (prof (derivation->output-path drv "out"))) |
b72a312c | 106 | (when (not (build-derivations store (list drv))) |
64d2e973 NK |
107 | (leave (_ "failed to build the empty profile~%"))) |
108 | ||
109 | (switch-symlinks generation prof))) | |
110 | ||
b3bb82f1 AK |
111 | (define (switch-to-generation profile number) |
112 | "Atomically switch PROFILE to the generation NUMBER." | |
113 | (let ((current (generation-number profile)) | |
114 | (generation (generation-file-name profile number))) | |
115 | (cond ((not (file-exists? profile)) | |
116 | (raise (condition (&profile-not-found-error | |
117 | (profile profile))))) | |
118 | ((not (file-exists? generation)) | |
119 | (raise (condition (&missing-generation-error | |
120 | (profile profile) | |
121 | (generation number))))) | |
122 | (else | |
123 | (format #t (_ "switching from generation ~a to ~a~%") | |
124 | current number) | |
125 | (switch-symlinks profile generation))))) | |
126 | ||
b7884ca3 NK |
127 | (define (switch-to-previous-generation profile) |
128 | "Atomically switch PROFILE to the previous generation." | |
b3bb82f1 AK |
129 | (switch-to-generation profile |
130 | (previous-generation-number profile))) | |
b7884ca3 | 131 | |
b72a312c | 132 | (define (roll-back store profile) |
24e262f0 | 133 | "Roll back to the previous generation of PROFILE." |
1b0a8212 NK |
134 | (let* ((number (generation-number profile)) |
135 | (previous-number (previous-generation-number profile number)) | |
3d6e65d5 | 136 | (previous-generation (generation-file-name profile previous-number))) |
b7884ca3 | 137 | (cond ((not (file-exists? profile)) ; invalid profile |
c0c018f1 AK |
138 | (raise (condition (&profile-not-found-error |
139 | (profile profile))))) | |
b7884ca3 | 140 | ((zero? number) ; empty profile |
c31d1a78 LC |
141 | (format (current-error-port) |
142 | (_ "nothing to do: already at the empty profile~%"))) | |
b7884ca3 | 143 | ((or (zero? previous-number) ; going to emptiness |
1b0a8212 | 144 | (not (file-exists? previous-generation))) |
b72a312c | 145 | (link-to-empty-profile store previous-generation) |
b7884ca3 NK |
146 | (switch-to-previous-generation profile)) |
147 | (else | |
148 | (switch-to-previous-generation profile))))) ; anything else | |
24e262f0 | 149 | |
b72a312c AK |
150 | (define (delete-generation store profile number) |
151 | "Delete generation with NUMBER from PROFILE." | |
152 | (define (display-and-delete) | |
153 | (let ((generation (generation-file-name profile number))) | |
154 | (format #t (_ "deleting ~a~%") generation) | |
155 | (delete-file generation))) | |
156 | ||
157 | (let* ((current-number (generation-number profile)) | |
158 | (previous-number (previous-generation-number profile number)) | |
159 | (previous-generation (generation-file-name profile previous-number))) | |
160 | (cond ((zero? number)) ; do not delete generation 0 | |
161 | ((and (= number current-number) | |
162 | (not (file-exists? previous-generation))) | |
163 | (link-to-empty-profile store previous-generation) | |
164 | (switch-to-previous-generation profile) | |
165 | (display-and-delete)) | |
166 | ((= number current-number) | |
167 | (roll-back store profile) | |
168 | (display-and-delete)) | |
169 | (else | |
170 | (display-and-delete))))) | |
171 | ||
172 | (define (delete-generations store profile generations) | |
173 | "Delete GENERATIONS from PROFILE. | |
174 | GENERATIONS is a list of generation numbers." | |
175 | (for-each (cut delete-generation store profile <>) | |
176 | generations)) | |
177 | ||
d7ddb257 LC |
178 | (define* (matching-generations str #:optional (profile %current-profile) |
179 | #:key (duration-relation <=)) | |
2cd09108 | 180 | "Return the list of available generations matching a pattern in STR. See |
d7ddb257 LC |
181 | 'string->generations' and 'string->duration' for the list of valid patterns. |
182 | When STR is a duration pattern, return all the generations whose ctime has | |
183 | DURATION-RELATION with the current time." | |
2cd09108 NK |
184 | (define (valid-generations lst) |
185 | (define (valid-generation? n) | |
186 | (any (cut = n <>) (generation-numbers profile))) | |
187 | ||
188 | (fold-right (lambda (x acc) | |
189 | (if (valid-generation? x) | |
190 | (cons x acc) | |
191 | acc)) | |
192 | '() | |
193 | lst)) | |
194 | ||
195 | (define (filter-generations generations) | |
196 | (match generations | |
197 | (() '()) | |
198 | (('>= n) | |
199 | (drop-while (cut > n <>) | |
200 | (generation-numbers profile))) | |
201 | (('<= n) | |
202 | (valid-generations (iota n 1))) | |
203 | ((lst ..1) | |
204 | (valid-generations lst)) | |
205 | (_ #f))) | |
206 | ||
207 | (define (filter-by-duration duration) | |
208 | (define (time-at-midnight time) | |
209 | ;; Return TIME at midnight by setting nanoseconds, seconds, minutes, and | |
210 | ;; hours to zeros. | |
211 | (let ((d (time-utc->date time))) | |
212 | (date->time-utc | |
213 | (make-date 0 0 0 0 | |
214 | (date-day d) (date-month d) | |
215 | (date-year d) (date-zone-offset d))))) | |
216 | ||
217 | (define generation-ctime-alist | |
218 | (map (lambda (number) | |
219 | (cons number | |
220 | (time-second | |
221 | (time-at-midnight | |
222 | (generation-time profile number))))) | |
223 | (generation-numbers profile))) | |
224 | ||
225 | (match duration | |
226 | (#f #f) | |
227 | (res | |
228 | (let ((s (time-second | |
229 | (subtract-duration (time-at-midnight (current-time)) | |
230 | duration)))) | |
231 | (delete #f (map (lambda (x) | |
d7ddb257 | 232 | (and (duration-relation s (cdr x)) |
2cd09108 NK |
233 | (first x))) |
234 | generation-ctime-alist)))))) | |
235 | ||
236 | (cond ((string->generations str) | |
237 | => | |
238 | filter-generations) | |
239 | ((string->duration str) | |
240 | => | |
241 | filter-by-duration) | |
242 | (else #f))) | |
243 | ||
65d428d8 LC |
244 | (define (delete-matching-generations store profile pattern) |
245 | "Delete from PROFILE all the generations matching PATTERN. PATTERN must be | |
246 | a string denoting a set of generations: the empty list means \"all generations | |
247 | but the current one\", a number designates a generation, and other patterns | |
248 | denote ranges as interpreted by 'matching-derivations'." | |
249 | (let ((current (generation-number profile))) | |
250 | (cond ((not (file-exists? profile)) ; XXX: race condition | |
251 | (raise (condition (&profile-not-found-error | |
252 | (profile profile))))) | |
253 | ((string-null? pattern) | |
254 | (delete-generations (%store) profile | |
255 | (delv current (profile-generations profile)))) | |
256 | ;; Do not delete the zeroth generation. | |
257 | ((equal? 0 (string->number pattern)) | |
250bc998 | 258 | #t) |
65d428d8 LC |
259 | |
260 | ;; If PATTERN is a duration, match generations that are | |
261 | ;; older than the specified duration. | |
262 | ((matching-generations pattern profile | |
263 | #:duration-relation >) | |
264 | => | |
265 | (lambda (numbers) | |
d26eb84d LC |
266 | (when (memv current numbers) |
267 | (warning (_ "not removing generation ~a, which is current~%") | |
268 | current)) | |
269 | ||
270 | ;; Make sure we don't inadvertently remove the current | |
271 | ;; generation. | |
272 | (let ((numbers (delv current numbers))) | |
250bc998 LC |
273 | (when (null-list? numbers) |
274 | (leave (_ "no matching generation~%"))) | |
275 | (delete-generations (%store) profile numbers)))) | |
65d428d8 LC |
276 | (else |
277 | (leave (_ "invalid syntax: ~a~%") pattern))))) | |
278 | ||
cc4ecc2d LC |
279 | \f |
280 | ;;; | |
281 | ;;; Package specifications. | |
282 | ;;; | |
283 | ||
acc08466 | 284 | (define (find-packages-by-description rx) |
b2ba65c8 LC |
285 | "Return the list of packages whose name, synopsis, or description matches |
286 | RX." | |
051edc95 LC |
287 | (define version<? (negate version>=?)) |
288 | ||
9eeb3d8c LC |
289 | (sort |
290 | (fold-packages (lambda (package result) | |
291 | (define matches? | |
292 | (cut regexp-exec rx <>)) | |
acc08466 | 293 | |
9eeb3d8c LC |
294 | (if (or (matches? (package-name package)) |
295 | (and=> (package-synopsis package) | |
296 | (compose matches? P_)) | |
297 | (and=> (package-description package) | |
298 | (compose matches? P_))) | |
299 | (cons package result) | |
300 | result)) | |
301 | '()) | |
302 | (lambda (p1 p2) | |
051edc95 LC |
303 | (case (string-compare (package-name p1) (package-name p2) |
304 | (const '<) (const '=) (const '>)) | |
305 | ((=) (version<? (package-version p1) (package-version p2))) | |
306 | ((<) #t) | |
307 | (else #f))))) | |
acc08466 | 308 | |
1a43e4dc LC |
309 | (define-syntax-rule (leave-on-EPIPE exp ...) |
310 | "Run EXP... in a context when EPIPE errors are caught and lead to 'exit' | |
311 | with successful exit code. This is useful when writing to the standard output | |
312 | may lead to EPIPE, because the standard output is piped through 'head' or | |
313 | similar." | |
314 | (catch 'system-error | |
315 | (lambda () | |
316 | exp ...) | |
317 | (lambda args | |
318 | ;; We really have to exit this brutally, otherwise Guile eventually | |
319 | ;; attempts to flush all the ports, leading to an uncaught EPIPE down | |
320 | ;; the path. | |
321 | (if (= EPIPE (system-error-errno args)) | |
322 | (primitive-_exit 0) | |
323 | (apply throw args))))) | |
324 | ||
edac8846 | 325 | (define* (specification->package+output spec #:optional (output "out")) |
760c60d6 | 326 | "Return the package and output specified by SPEC, or #f and #f; SPEC may |
edac8846 | 327 | optionally contain a version number and an output name, as in these examples: |
d46d8794 | 328 | |
edac8846 LC |
329 | guile |
330 | guile-2.0.9 | |
331 | guile:debug | |
332 | guile-2.0.9:debug | |
333 | ||
334 | If SPEC does not specify a version number, return the preferred newest | |
335 | version; if SPEC does not specify an output, return OUTPUT." | |
d46d8794 LC |
336 | (define (ensure-output p sub-drv) |
337 | (if (member sub-drv (package-outputs p)) | |
edac8846 | 338 | sub-drv |
d46d8794 LC |
339 | (leave (_ "package `~a' lacks output `~a'~%") |
340 | (package-full-name p) | |
341 | sub-drv))) | |
342 | ||
2876b989 | 343 | (let-values (((name version sub-drv) |
b874f305 | 344 | (package-specification->name+version+output spec output))) |
d46d8794 LC |
345 | (match (find-best-packages-by-name name version) |
346 | ((p) | |
edac8846 | 347 | (values p (ensure-output p sub-drv))) |
d46d8794 LC |
348 | ((p p* ...) |
349 | (warning (_ "ambiguous package specification `~a'~%") | |
edac8846 | 350 | spec) |
d46d8794 LC |
351 | (warning (_ "choosing ~a from ~a~%") |
352 | (package-full-name p) | |
353 | (location->string (package-location p))) | |
edac8846 | 354 | (values p (ensure-output p sub-drv))) |
d46d8794 | 355 | (() |
edac8846 | 356 | (leave (_ "~a: package not found~%") spec))))) |
d46d8794 LC |
357 | |
358 | (define (upgradeable? name current-version current-path) | |
359 | "Return #t if there's a version of package NAME newer than CURRENT-VERSION, | |
360 | or if the newest available version is equal to CURRENT-VERSION but would have | |
361 | an output path different than CURRENT-PATH." | |
3f26bfc1 | 362 | (match (vhash-assoc name (find-newest-available-packages)) |
d46d8794 LC |
363 | ((_ candidate-version pkg . rest) |
364 | (case (version-compare candidate-version current-version) | |
365 | ((>) #t) | |
366 | ((<) #f) | |
367 | ((=) (let ((candidate-path (derivation->output-path | |
368 | (package-derivation (%store) pkg)))) | |
369 | (not (string=? current-path candidate-path)))))) | |
370 | (#f #f))) | |
371 | ||
d46d8794 LC |
372 | \f |
373 | ;;; | |
374 | ;;; Search paths. | |
375 | ;;; | |
376 | ||
1a096504 LC |
377 | (define-syntax-rule (with-null-error-port exp) |
378 | "Evaluate EXP with the error port pointing to the bit bucket." | |
379 | (with-error-to-port (%make-void-port "w") | |
380 | (lambda () exp))) | |
381 | ||
f067fc3e | 382 | (define* (search-path-environment-variables entries profile |
5924080d LC |
383 | #:optional (getenv getenv)) |
384 | "Return environment variable definitions that may be needed for the use of | |
f067fc3e LC |
385 | ENTRIES, a list of manifest entries, in PROFILE. Use GETENV to determine the |
386 | current settings and report only settings not already effective." | |
3badccaa LC |
387 | (define search-path-definition |
388 | (match-lambda | |
389 | (($ <search-path-specification> variable files separator | |
390 | type pattern) | |
391 | (let* ((values (or (and=> (getenv variable) | |
392 | (cut string-tokenize* <> separator)) | |
393 | '())) | |
394 | ;; Add a trailing slash to force symlinks to be treated as | |
395 | ;; directories when 'find-files' traverses them. | |
396 | (files (if pattern | |
397 | (map (cut string-append <> "/") files) | |
398 | files)) | |
399 | ||
400 | ;; XXX: Silence 'find-files' when it stumbles upon non-existent | |
401 | ;; directories (see | |
402 | ;; <http://lists.gnu.org/archive/html/guix-devel/2015-01/msg00269.html>.) | |
403 | (path (with-null-error-port | |
404 | (search-path-as-list files (list profile) | |
405 | #:type type | |
406 | #:pattern pattern)))) | |
407 | (if (every (cut member <> values) path) | |
408 | #f | |
409 | (format #f "export ~a=\"~a\"" | |
410 | variable | |
411 | (string-join path separator))))))) | |
412 | ||
413 | (let ((search-paths (delete-duplicates | |
414 | (append-map manifest-entry-search-paths entries)))) | |
415 | (filter-map search-path-definition search-paths))) | |
5924080d | 416 | |
f067fc3e | 417 | (define (display-search-paths entries profile) |
5924080d | 418 | "Display the search path environment variables that may need to be set for |
f067fc3e | 419 | ENTRIES, a list of manifest entries, in the context of PROFILE." |
3badccaa LC |
420 | (let* ((profile (user-friendly-profile profile)) |
421 | (settings (search-path-environment-variables entries profile))) | |
5924080d LC |
422 | (unless (null? settings) |
423 | (format #t (_ "The following environment variable definitions may be needed:~%")) | |
a81bc531 | 424 | (format #t "~{ ~a~%~}" settings)))) |
5924080d | 425 | |
0afdc485 LC |
426 | \f |
427 | ;;; | |
428 | ;;; Command-line options. | |
429 | ;;; | |
430 | ||
431 | (define %default-options | |
432 | ;; Alist of default option values. | |
3b824605 | 433 | `((profile . ,%current-profile) |
969e678e | 434 | (max-silent-time . 3600) |
dd67b429 | 435 | (verbosity . 0) |
3b824605 | 436 | (substitutes? . #t))) |
0afdc485 | 437 | |
0afdc485 | 438 | (define (show-help) |
e49951eb | 439 | (display (_ "Usage: guix package [OPTION]... PACKAGES... |
0afdc485 LC |
440 | Install, remove, or upgrade PACKAGES in a single transaction.\n")) |
441 | (display (_ " | |
442 | -i, --install=PACKAGE install PACKAGE")) | |
443 | (display (_ " | |
5d4b411f LC |
444 | -e, --install-from-expression=EXP |
445 | install the package EXP evaluates to")) | |
446 | (display (_ " | |
0afdc485 LC |
447 | -r, --remove=PACKAGE remove PACKAGE")) |
448 | (display (_ " | |
acb6ba25 | 449 | -u, --upgrade[=REGEXP] upgrade all the installed packages matching REGEXP")) |
d5f01e48 MW |
450 | (display (_ " |
451 | --do-not-upgrade[=REGEXP] do not upgrade any packages matching REGEXP")) | |
24e262f0 LC |
452 | (display (_ " |
453 | --roll-back roll back to the previous generation")) | |
5924080d LC |
454 | (display (_ " |
455 | --search-paths display needed environment variable definitions")) | |
2cd09108 NK |
456 | (display (_ " |
457 | -l, --list-generations[=PATTERN] | |
458 | list generations matching PATTERN")) | |
b7884ca3 NK |
459 | (display (_ " |
460 | -d, --delete-generations[=PATTERN] | |
461 | delete generations matching PATTERN")) | |
0afdc485 | 462 | (display (_ " |
b3bb82f1 AK |
463 | -S, --switch-generation=PATTERN |
464 | switch to a generation matching PATTERN")) | |
465 | (display (_ " | |
0afdc485 | 466 | -p, --profile=PROFILE use PROFILE instead of the user's default profile")) |
dd67b429 | 467 | (newline) |
0afdc485 | 468 | (display (_ " |
cc57f25d | 469 | --bootstrap use the bootstrap Guile to build the profile")) |
70915c1a LC |
470 | (display (_ " |
471 | --verbose produce verbose output")) | |
0afdc485 LC |
472 | (newline) |
473 | (display (_ " | |
acc08466 NK |
474 | -s, --search=REGEXP search in synopsis and description using REGEXP")) |
475 | (display (_ " | |
733b4130 LC |
476 | -I, --list-installed[=REGEXP] |
477 | list installed packages matching REGEXP")) | |
64fc89b6 LC |
478 | (display (_ " |
479 | -A, --list-available[=REGEXP] | |
480 | list available packages matching REGEXP")) | |
2aa6efb0 CR |
481 | (display (_ " |
482 | --show=PACKAGE show details about PACKAGE")) | |
733b4130 | 483 | (newline) |
dd67b429 LC |
484 | (show-build-options-help) |
485 | (newline) | |
733b4130 | 486 | (display (_ " |
0afdc485 LC |
487 | -h, --help display this help and exit")) |
488 | (display (_ " | |
489 | -V, --version display version information and exit")) | |
490 | (newline) | |
3441e164 | 491 | (show-bug-report-information)) |
0afdc485 LC |
492 | |
493 | (define %options | |
494 | ;; Specification of the command-line options. | |
dd67b429 LC |
495 | (cons* (option '(#\h "help") #f #f |
496 | (lambda args | |
497 | (show-help) | |
498 | (exit 0))) | |
499 | (option '(#\V "version") #f #f | |
500 | (lambda args | |
501 | (show-version-and-exit "guix package"))) | |
502 | ||
503 | (option '(#\i "install") #f #t | |
504 | (lambda (opt name arg result arg-handler) | |
505 | (let arg-handler ((arg arg) (result result)) | |
506 | (values (if arg | |
507 | (alist-cons 'install arg result) | |
508 | result) | |
509 | arg-handler)))) | |
510 | (option '(#\e "install-from-expression") #t #f | |
511 | (lambda (opt name arg result arg-handler) | |
512 | (values (alist-cons 'install (read/eval-package-expression arg) | |
513 | result) | |
514 | #f))) | |
515 | (option '(#\r "remove") #f #t | |
516 | (lambda (opt name arg result arg-handler) | |
517 | (let arg-handler ((arg arg) (result result)) | |
518 | (values (if arg | |
519 | (alist-cons 'remove arg result) | |
520 | result) | |
521 | arg-handler)))) | |
522 | (option '(#\u "upgrade") #f #t | |
523 | (lambda (opt name arg result arg-handler) | |
524 | (let arg-handler ((arg arg) (result result)) | |
525 | (values (alist-cons 'upgrade arg | |
526 | ;; Delete any prior "upgrade all" | |
527 | ;; command, or else "--upgrade gcc" | |
528 | ;; would upgrade everything. | |
529 | (delete '(upgrade . #f) result)) | |
530 | arg-handler)))) | |
d5f01e48 MW |
531 | (option '("do-not-upgrade") #f #t |
532 | (lambda (opt name arg result arg-handler) | |
533 | (let arg-handler ((arg arg) (result result)) | |
534 | (values (if arg | |
535 | (alist-cons 'do-not-upgrade arg result) | |
536 | result) | |
537 | arg-handler)))) | |
dd67b429 LC |
538 | (option '("roll-back") #f #f |
539 | (lambda (opt name arg result arg-handler) | |
540 | (values (alist-cons 'roll-back? #t result) | |
541 | #f))) | |
542 | (option '(#\l "list-generations") #f #t | |
543 | (lambda (opt name arg result arg-handler) | |
544 | (values (cons `(query list-generations ,(or arg "")) | |
545 | result) | |
546 | #f))) | |
547 | (option '(#\d "delete-generations") #f #t | |
548 | (lambda (opt name arg result arg-handler) | |
549 | (values (alist-cons 'delete-generations (or arg "") | |
550 | result) | |
551 | #f))) | |
b3bb82f1 AK |
552 | (option '(#\S "switch-generation") #t #f |
553 | (lambda (opt name arg result arg-handler) | |
554 | (values (alist-cons 'switch-generation arg result) | |
555 | #f))) | |
dd67b429 LC |
556 | (option '("search-paths") #f #f |
557 | (lambda (opt name arg result arg-handler) | |
558 | (values (cons `(query search-paths) result) | |
559 | #f))) | |
560 | (option '(#\p "profile") #t #f | |
561 | (lambda (opt name arg result arg-handler) | |
88371f0d | 562 | (values (alist-cons 'profile (canonicalize-profile arg) |
dd67b429 LC |
563 | (alist-delete 'profile result)) |
564 | #f))) | |
565 | (option '(#\n "dry-run") #f #f | |
566 | (lambda (opt name arg result arg-handler) | |
567 | (values (alist-cons 'dry-run? #t result) | |
568 | #f))) | |
569 | (option '("bootstrap") #f #f | |
570 | (lambda (opt name arg result arg-handler) | |
571 | (values (alist-cons 'bootstrap? #t result) | |
572 | #f))) | |
573 | (option '("verbose") #f #f | |
574 | (lambda (opt name arg result arg-handler) | |
575 | (values (alist-cons 'verbose? #t result) | |
576 | #f))) | |
577 | (option '(#\s "search") #t #f | |
578 | (lambda (opt name arg result arg-handler) | |
579 | (values (cons `(query search ,(or arg "")) | |
580 | result) | |
581 | #f))) | |
582 | (option '(#\I "list-installed") #f #t | |
583 | (lambda (opt name arg result arg-handler) | |
584 | (values (cons `(query list-installed ,(or arg "")) | |
585 | result) | |
586 | #f))) | |
587 | (option '(#\A "list-available") #f #t | |
588 | (lambda (opt name arg result arg-handler) | |
589 | (values (cons `(query list-available ,(or arg "")) | |
590 | result) | |
591 | #f))) | |
2aa6efb0 CR |
592 | (option '("show") #t #t |
593 | (lambda (opt name arg result arg-handler) | |
594 | (values (cons `(query show ,arg) | |
595 | result) | |
596 | #f))) | |
dd67b429 LC |
597 | |
598 | %standard-build-options)) | |
0afdc485 | 599 | |
f067fc3e LC |
600 | (define (options->installable opts manifest) |
601 | "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold', | |
1fcc3ba3 | 602 | return the new list of manifest entries." |
462f5cca LC |
603 | (define (package->manifest-entry* package output) |
604 | (check-package-freshness package) | |
edac8846 LC |
605 | ;; When given a package via `-e', install the first of its |
606 | ;; outputs (XXX). | |
462f5cca | 607 | (package->manifest-entry package output)) |
edac8846 LC |
608 | |
609 | (define upgrade-regexps | |
610 | (filter-map (match-lambda | |
611 | (('upgrade . regexp) | |
612 | (make-regexp (or regexp ""))) | |
613 | (_ #f)) | |
614 | opts)) | |
615 | ||
d5f01e48 MW |
616 | (define do-not-upgrade-regexps |
617 | (filter-map (match-lambda | |
618 | (('do-not-upgrade . regexp) | |
619 | (make-regexp regexp)) | |
620 | (_ #f)) | |
621 | opts)) | |
622 | ||
edac8846 LC |
623 | (define packages-to-upgrade |
624 | (match upgrade-regexps | |
625 | (() | |
626 | '()) | |
627 | ((_ ...) | |
3d6e65d5 LC |
628 | (filter-map (match-lambda |
629 | (($ <manifest-entry> name version output path _) | |
630 | (and (any (cut regexp-exec <> name) | |
631 | upgrade-regexps) | |
d5f01e48 MW |
632 | (not (any (cut regexp-exec <> name) |
633 | do-not-upgrade-regexps)) | |
3d6e65d5 LC |
634 | (upgradeable? name version path) |
635 | (let ((output (or output "out"))) | |
636 | (call-with-values | |
637 | (lambda () | |
638 | (specification->package+output name output)) | |
639 | list)))) | |
640 | (_ #f)) | |
641 | (manifest-entries manifest))))) | |
edac8846 LC |
642 | |
643 | (define to-upgrade | |
644 | (map (match-lambda | |
645 | ((package output) | |
462f5cca | 646 | (package->manifest-entry* package output))) |
edac8846 LC |
647 | packages-to-upgrade)) |
648 | ||
649 | (define packages-to-install | |
650 | (filter-map (match-lambda | |
651 | (('install . (? package? p)) | |
652 | (list p "out")) | |
653 | (('install . (? string? spec)) | |
654 | (and (not (store-path? spec)) | |
655 | (let-values (((package output) | |
656 | (specification->package+output spec))) | |
657 | (and package (list package output))))) | |
658 | (_ #f)) | |
659 | opts)) | |
660 | ||
661 | (define to-install | |
662 | (append (map (match-lambda | |
663 | ((package output) | |
462f5cca | 664 | (package->manifest-entry* package output))) |
edac8846 LC |
665 | packages-to-install) |
666 | (filter-map (match-lambda | |
667 | (('install . (? package?)) | |
668 | #f) | |
669 | (('install . (? store-path? path)) | |
670 | (let-values (((name version) | |
671 | (package-name->name+version | |
672 | (store-path-package-name path)))) | |
f067fc3e LC |
673 | (manifest-entry |
674 | (name name) | |
675 | (version version) | |
676 | (output #f) | |
a54c94a4 | 677 | (item path)))) |
edac8846 LC |
678 | (_ #f)) |
679 | opts))) | |
680 | ||
1fcc3ba3 | 681 | (append to-upgrade to-install)) |
edac8846 | 682 | |
537630c5 | 683 | (define (options->removable options manifest) |
a2078770 LC |
684 | "Given options, return the list of manifest patterns of packages to be |
685 | removed from MANIFEST." | |
686 | (filter-map (match-lambda | |
687 | (('remove . spec) | |
688 | (call-with-values | |
689 | (lambda () | |
690 | (package-specification->name+version+output spec)) | |
691 | (lambda (name version output) | |
692 | (manifest-pattern | |
693 | (name name) | |
694 | (version version) | |
695 | (output output))))) | |
696 | (_ #f)) | |
697 | options)) | |
537630c5 | 698 | |
c9323a4c LC |
699 | (define (register-gc-root store profile) |
700 | "Register PROFILE, a profile generation symlink, as a GC root, unless it | |
701 | doesn't need it." | |
702 | (define absolute | |
703 | ;; We must pass the daemon an absolute file name for PROFILE. However, we | |
704 | ;; cannot use (canonicalize-path profile) because that would return us the | |
705 | ;; target of PROFILE in the store; using a store item as an indirect root | |
706 | ;; would mean that said store item will always remain live, which is not | |
707 | ;; what we want here. | |
708 | (if (string-prefix? "/" profile) | |
709 | profile | |
710 | (string-append (getcwd) "/" profile))) | |
711 | ||
712 | (add-indirect-root store absolute)) | |
d2952326 | 713 | |
48704e5b LC |
714 | (define (readlink* file) |
715 | "Call 'readlink' until the result is not a symlink." | |
ee859199 LC |
716 | (define %max-symlink-depth 50) |
717 | ||
718 | (let loop ((file file) | |
719 | (depth 0)) | |
720 | (define (absolute target) | |
721 | (if (absolute-file-name? target) | |
722 | target | |
723 | (string-append (dirname file) "/" target))) | |
724 | ||
725 | (if (>= depth %max-symlink-depth) | |
726 | file | |
727 | (call-with-values | |
728 | (lambda () | |
729 | (catch 'system-error | |
730 | (lambda () | |
731 | (values #t (readlink file))) | |
732 | (lambda args | |
733 | (let ((errno (system-error-errno args))) | |
734 | (if (or (= errno EINVAL)) | |
735 | (values #f file) | |
736 | (apply throw args)))))) | |
737 | (lambda (success? target) | |
738 | (if success? | |
739 | (loop (absolute target) (+ depth 1)) | |
740 | file)))))) | |
48704e5b | 741 | |
0afdc485 LC |
742 | \f |
743 | ;;; | |
744 | ;;; Entry point. | |
745 | ;;; | |
746 | ||
747 | (define (guix-package . args) | |
b3f21389 LC |
748 | (define (handle-argument arg result arg-handler) |
749 | ;; Process non-option argument ARG by calling back ARG-HANDLER. | |
750 | (if arg-handler | |
751 | (arg-handler arg result) | |
752 | (leave (_ "~A: extraneous argument~%") arg))) | |
0afdc485 | 753 | |
0ec1af59 | 754 | (define (ensure-default-profile) |
70c43291 LC |
755 | ;; Ensure the default profile symlink and directory exist and are |
756 | ;; writable. | |
757 | ||
758 | (define (rtfm) | |
759 | (format (current-error-port) | |
760 | (_ "Try \"info '(guix) Invoking guix package'\" for \ | |
761 | more information.~%")) | |
762 | (exit 1)) | |
0ec1af59 LC |
763 | |
764 | ;; Create ~/.guix-profile if it doesn't exist yet. | |
d595e456 | 765 | (when (and %user-profile-directory |
0ec1af59 LC |
766 | %current-profile |
767 | (not (false-if-exception | |
d595e456 LC |
768 | (lstat %user-profile-directory)))) |
769 | (symlink %current-profile %user-profile-directory)) | |
0ec1af59 | 770 | |
70c43291 LC |
771 | (let ((s (stat %profile-directory #f))) |
772 | ;; Attempt to create /…/profiles/per-user/$USER if needed. | |
773 | (unless (and s (eq? 'directory (stat:type s))) | |
774 | (catch 'system-error | |
775 | (lambda () | |
776 | (mkdir-p %profile-directory)) | |
777 | (lambda args | |
778 | ;; Often, we cannot create %PROFILE-DIRECTORY because its | |
779 | ;; parent directory is root-owned and we're running | |
780 | ;; unprivileged. | |
781 | (format (current-error-port) | |
782 | (_ "error: while creating directory `~a': ~a~%") | |
783 | %profile-directory | |
784 | (strerror (system-error-errno args))) | |
785 | (format (current-error-port) | |
786 | (_ "Please create the `~a' directory, with you as the owner.~%") | |
787 | %profile-directory) | |
788 | (rtfm)))) | |
789 | ||
790 | ;; Bail out if it's not owned by the user. | |
cba363be | 791 | (unless (or (not s) (= (stat:uid s) (getuid))) |
70c43291 LC |
792 | (format (current-error-port) |
793 | (_ "error: directory `~a' is not owned by you~%") | |
794 | %profile-directory) | |
795 | (format (current-error-port) | |
796 | (_ "Please change the owner of `~a' to user ~s.~%") | |
6879fe23 TUBK |
797 | %profile-directory (or (getenv "USER") |
798 | (getenv "LOGNAME") | |
799 | (getuid))) | |
70c43291 | 800 | (rtfm)))) |
0ec1af59 | 801 | |
733b4130 LC |
802 | (define (process-actions opts) |
803 | ;; Process any install/remove/upgrade action from OPTS. | |
24e262f0 LC |
804 | |
805 | (define dry-run? (assoc-ref opts 'dry-run?)) | |
24e262f0 LC |
806 | (define profile (assoc-ref opts 'profile)) |
807 | ||
808 | ;; First roll back if asked to. | |
b3bb82f1 AK |
809 | (cond ((and (assoc-ref opts 'roll-back?) |
810 | (not dry-run?)) | |
811 | (roll-back (%store) profile) | |
812 | (process-actions (alist-delete 'roll-back? opts))) | |
813 | ((and (assoc-ref opts 'switch-generation) | |
814 | (not dry-run?)) | |
815 | (for-each | |
816 | (match-lambda | |
817 | (('switch-generation . pattern) | |
818 | (let* ((number (string->number pattern)) | |
819 | (number (and number | |
820 | (case (string-ref pattern 0) | |
821 | ((#\+ #\-) | |
822 | (relative-generation profile number)) | |
823 | (else number))))) | |
824 | (if number | |
825 | (switch-to-generation profile number) | |
826 | (leave (_ "cannot switch to generation '~a'~%") | |
827 | pattern))) | |
828 | (process-actions (alist-delete 'switch-generation opts))) | |
829 | (_ #f)) | |
830 | opts)) | |
b7884ca3 NK |
831 | ((and (assoc-ref opts 'delete-generations) |
832 | (not dry-run?)) | |
b3bb82f1 | 833 | (for-each |
b7884ca3 NK |
834 | (match-lambda |
835 | (('delete-generations . pattern) | |
65d428d8 | 836 | (delete-matching-generations (%store) profile pattern) |
b7884ca3 NK |
837 | |
838 | (process-actions | |
839 | (alist-delete 'delete-generations opts))) | |
840 | (_ #f)) | |
841 | opts)) | |
842 | (else | |
89caec69 AK |
843 | (let* ((manifest (profile-manifest profile)) |
844 | (install (options->installable opts manifest)) | |
845 | (remove (options->removable opts manifest)) | |
79ee406d | 846 | (bootstrap? (assoc-ref opts 'bootstrap?)) |
89caec69 AK |
847 | (transaction (manifest-transaction (install install) |
848 | (remove remove))) | |
849 | (new (manifest-perform-transaction | |
850 | manifest transaction))) | |
1fcc3ba3 LC |
851 | |
852 | (when (equal? profile %current-profile) | |
853 | (ensure-default-profile)) | |
854 | ||
48704e5b | 855 | (unless (and (null? install) (null? remove)) |
a54c94a4 | 856 | (let* ((prof-drv (run-with-store (%store) |
79ee406d LC |
857 | (profile-derivation |
858 | new | |
aa46a028 LC |
859 | #:hooks (if bootstrap? |
860 | '() | |
861 | %default-profile-hooks)))) | |
89caec69 | 862 | (prof (derivation->output-path prof-drv))) |
5d7a8584 | 863 | (show-manifest-transaction (%store) manifest transaction |
89caec69 | 864 | #:dry-run? dry-run?) |
48704e5b LC |
865 | (show-what-to-build (%store) (list prof-drv) |
866 | #:use-substitutes? | |
867 | (assoc-ref opts 'substitutes?) | |
868 | #:dry-run? dry-run?) | |
869 | ||
870 | (cond | |
871 | (dry-run? #t) | |
872 | ((and (file-exists? profile) | |
873 | (and=> (readlink* profile) (cut string=? prof <>))) | |
874 | (format (current-error-port) (_ "nothing to be done~%"))) | |
875 | (else | |
876 | (let* ((number (generation-number profile)) | |
877 | ||
878 | ;; Always use NUMBER + 1 for the new profile, | |
879 | ;; possibly overwriting a "previous future | |
880 | ;; generation". | |
881 | (name (generation-file-name profile | |
882 | (+ 1 number)))) | |
883 | (and (build-derivations (%store) (list prof-drv)) | |
f48624fc LC |
884 | (let* ((entries (manifest-entries new)) |
885 | (count (length entries))) | |
48704e5b LC |
886 | (switch-symlinks name prof) |
887 | (switch-symlinks profile name) | |
c9323a4c LC |
888 | (unless (string=? profile %current-profile) |
889 | (register-gc-root (%store) name)) | |
48704e5b LC |
890 | (format #t (N_ "~a package in profile~%" |
891 | "~a packages in profile~%" | |
892 | count) | |
893 | count) | |
894 | (display-search-paths entries | |
895 | profile)))))))))))) | |
733b4130 LC |
896 | |
897 | (define (process-query opts) | |
898 | ;; Process any query specified by OPTS. Return #t when a query was | |
899 | ;; actually processed, #f otherwise. | |
900 | (let ((profile (assoc-ref opts 'profile))) | |
901 | (match (assoc-ref opts 'query) | |
2cd09108 NK |
902 | (('list-generations pattern) |
903 | (define (list-generation number) | |
4b2bc804 | 904 | (unless (zero? number) |
9ac9360d NK |
905 | (let ((header (format #f (_ "Generation ~a\t~a") number |
906 | (date->string | |
907 | (time-utc->date | |
908 | (generation-time profile number)) | |
909 | "~b ~d ~Y ~T"))) | |
910 | (current (generation-number profile))) | |
911 | (if (= number current) | |
912 | (format #t (_ "~a\t(current)~%") header) | |
913 | (format #t "~a~%" header))) | |
2cd09108 | 914 | (for-each (match-lambda |
f067fc3e | 915 | (($ <manifest-entry> name version output location _) |
2cd09108 NK |
916 | (format #t " ~a\t~a\t~a\t~a~%" |
917 | name version output location))) | |
bd9bde1c LC |
918 | |
919 | ;; Show most recently installed packages last. | |
920 | (reverse | |
f067fc3e | 921 | (manifest-entries |
bd9bde1c | 922 | (profile-manifest |
477d30d0 | 923 | (generation-file-name profile number))))) |
2cd09108 NK |
924 | (newline))) |
925 | ||
926 | (cond ((not (file-exists? profile)) ; XXX: race condition | |
c0c018f1 AK |
927 | (raise (condition (&profile-not-found-error |
928 | (profile profile))))) | |
2cd09108 | 929 | ((string-null? pattern) |
886cf584 | 930 | (for-each list-generation (profile-generations profile))) |
2cd09108 NK |
931 | ((matching-generations pattern profile) |
932 | => | |
0ab212b9 NK |
933 | (lambda (numbers) |
934 | (if (null-list? numbers) | |
935 | (exit 1) | |
1a43e4dc LC |
936 | (leave-on-EPIPE |
937 | (for-each list-generation numbers))))) | |
2cd09108 NK |
938 | (else |
939 | (leave (_ "invalid syntax: ~a~%") | |
940 | pattern))) | |
941 | #t) | |
942 | ||
733b4130 LC |
943 | (('list-installed regexp) |
944 | (let* ((regexp (and regexp (make-regexp regexp))) | |
945 | (manifest (profile-manifest profile)) | |
f067fc3e | 946 | (installed (manifest-entries manifest))) |
1a43e4dc LC |
947 | (leave-on-EPIPE |
948 | (for-each (match-lambda | |
949 | (($ <manifest-entry> name version output path _) | |
950 | (when (or (not regexp) | |
951 | (regexp-exec regexp name)) | |
952 | (format #t "~a\t~a\t~a\t~a~%" | |
953 | name (or version "?") output path)))) | |
954 | ||
955 | ;; Show most recently installed packages last. | |
956 | (reverse installed))) | |
64fc89b6 | 957 | #t)) |
acc08466 | 958 | |
64fc89b6 LC |
959 | (('list-available regexp) |
960 | (let* ((regexp (and regexp (make-regexp regexp))) | |
961 | (available (fold-packages | |
962 | (lambda (p r) | |
963 | (let ((n (package-name p))) | |
5763ad92 LC |
964 | (if (supported-package? p) |
965 | (if regexp | |
966 | (if (regexp-exec regexp n) | |
967 | (cons p r) | |
968 | r) | |
969 | (cons p r)) | |
970 | r))) | |
64fc89b6 | 971 | '()))) |
1a43e4dc LC |
972 | (leave-on-EPIPE |
973 | (for-each (lambda (p) | |
974 | (format #t "~a\t~a\t~a\t~a~%" | |
975 | (package-name p) | |
976 | (package-version p) | |
977 | (string-join (package-outputs p) ",") | |
978 | (location->string (package-location p)))) | |
979 | (sort available | |
980 | (lambda (p1 p2) | |
981 | (string<? (package-name p1) | |
982 | (package-name p2)))))) | |
64fc89b6 | 983 | #t)) |
acc08466 NK |
984 | |
985 | (('search regexp) | |
cb09fb24 | 986 | (let ((regexp (make-regexp regexp regexp/icase))) |
eb9a9fee LC |
987 | (leave-on-EPIPE |
988 | (for-each (cute package->recutils <> (current-output-port)) | |
989 | (find-packages-by-description regexp))) | |
acc08466 | 990 | #t)) |
5924080d | 991 | |
2aa6efb0 CR |
992 | (('show requested-name) |
993 | (let-values (((name version) | |
994 | (package-name->name+version requested-name))) | |
995 | (leave-on-EPIPE | |
996 | (for-each (cute package->recutils <> (current-output-port)) | |
997 | (find-packages-by-name name version))) | |
998 | #t)) | |
999 | ||
5924080d LC |
1000 | (('search-paths) |
1001 | (let* ((manifest (profile-manifest profile)) | |
f067fc3e | 1002 | (entries (manifest-entries manifest)) |
3badccaa | 1003 | (profile (user-friendly-profile profile)) |
f067fc3e | 1004 | (settings (search-path-environment-variables entries profile |
5924080d LC |
1005 | (const #f)))) |
1006 | (format #t "~{~a~%~}" settings) | |
1007 | #t)) | |
1008 | ||
733b4130 LC |
1009 | (_ #f)))) |
1010 | ||
b3f21389 LC |
1011 | (let ((opts (parse-command-line args %options (list %default-options #f) |
1012 | #:argument-handler handle-argument))) | |
c0c018f1 AK |
1013 | (with-error-handling |
1014 | (or (process-query opts) | |
ef86c39f | 1015 | (parameterize ((%store (open-connection))) |
dd67b429 | 1016 | (set-build-options-from-command-line (%store) opts) |
3b824605 | 1017 | |
c4d64534 | 1018 | (parameterize ((%guile-for-build |
bdb36958 LC |
1019 | (package-derivation |
1020 | (%store) | |
1021 | (if (assoc-ref opts 'bootstrap?) | |
1022 | %bootstrap-guile | |
1023 | (canonical-package guile-2.0))))) | |
c4d64534 | 1024 | (process-actions opts))))))) |