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