Commit | Line | Data |
---|---|---|
233e7676 LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2012, 2013 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) | |
26 | #:use-module (guix utils) | |
a020d2a9 | 27 | #:use-module (guix config) |
0ec1af59 | 28 | #:use-module ((guix build utils) #:select (directory-exists? mkdir-p)) |
e3ccdf9e | 29 | #:use-module ((guix ftp-client) #:select (ftp-open)) |
0afdc485 LC |
30 | #:use-module (ice-9 ftw) |
31 | #:use-module (ice-9 format) | |
32 | #:use-module (ice-9 match) | |
33 | #:use-module (ice-9 regex) | |
dc5669cd | 34 | #:use-module (ice-9 vlist) |
0afdc485 LC |
35 | #:use-module (srfi srfi-1) |
36 | #:use-module (srfi srfi-11) | |
2cd09108 | 37 | #:use-module (srfi srfi-19) |
0afdc485 LC |
38 | #:use-module (srfi srfi-26) |
39 | #:use-module (srfi srfi-34) | |
40 | #:use-module (srfi srfi-37) | |
59a43334 | 41 | #:use-module (gnu packages) |
1ffa7090 LC |
42 | #:use-module ((gnu packages base) #:select (guile-final)) |
43 | #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) | |
ef010c0f | 44 | #:use-module (guix gnu-maintenance) |
0afdc485 LC |
45 | #:export (guix-package)) |
46 | ||
0afdc485 | 47 | (define %store |
c4d64534 | 48 | (make-parameter #f)) |
0afdc485 LC |
49 | |
50 | \f | |
51 | ;;; | |
52 | ;;; User environment. | |
53 | ;;; | |
54 | ||
55 | (define %user-environment-directory | |
56 | (and=> (getenv "HOME") | |
57 | (cut string-append <> "/.guix-profile"))) | |
58 | ||
59 | (define %profile-directory | |
0ec1af59 | 60 | (string-append (or (getenv "NIX_STATE_DIR") %state-directory) "/profiles/" |
0afdc485 LC |
61 | (or (and=> (getenv "USER") |
62 | (cut string-append "per-user/" <>)) | |
63 | "default"))) | |
64 | ||
65 | (define %current-profile | |
4aa52039 LC |
66 | ;; Call it `guix-profile', not `profile', to allow Guix profiles to |
67 | ;; coexist with Nix profiles. | |
68 | (string-append %profile-directory "/guix-profile")) | |
0afdc485 LC |
69 | |
70 | (define (profile-manifest profile) | |
71 | "Return the PROFILE's manifest." | |
72 | (let ((manifest (string-append profile "/manifest"))) | |
73 | (if (file-exists? manifest) | |
74 | (call-with-input-file manifest read) | |
4dede022 | 75 | '(manifest (version 1) (packages ()))))) |
0afdc485 LC |
76 | |
77 | (define (manifest-packages manifest) | |
78 | "Return the packages listed in MANIFEST." | |
79 | (match manifest | |
4dede022 LC |
80 | (('manifest ('version 0) |
81 | ('packages ((name version output path) ...))) | |
82 | (zip name version output path | |
83 | (make-list (length name) '()))) | |
84 | ||
85 | ;; Version 1 adds a list of propagated inputs to the | |
86 | ;; name/version/output/path tuples. | |
87 | (('manifest ('version 1) | |
88 | ('packages (packages ...))) | |
0afdc485 | 89 | packages) |
4dede022 | 90 | |
0afdc485 LC |
91 | (_ |
92 | (error "unsupported manifest format" manifest)))) | |
93 | ||
24e262f0 LC |
94 | (define (profile-regexp profile) |
95 | "Return a regular expression that matches PROFILE's name and number." | |
96 | (make-regexp (string-append "^" (regexp-quote (basename profile)) | |
97 | "-([0-9]+)"))) | |
98 | ||
1b0a8212 | 99 | (define (generation-numbers profile) |
99882c61 | 100 | "Return the sorted list of generation numbers of PROFILE, or '(0) if no |
9241172c | 101 | former profiles were found." |
0afdc485 LC |
102 | (define* (scandir name #:optional (select? (const #t)) |
103 | (entry<? (@ (ice-9 i18n) string-locale<?))) | |
104 | ;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19. | |
105 | (define (enter? dir stat result) | |
106 | (and stat (string=? dir name))) | |
107 | ||
108 | (define (visit basename result) | |
109 | (if (select? basename) | |
110 | (cons basename result) | |
111 | result)) | |
112 | ||
113 | (define (leaf name stat result) | |
114 | (and result | |
115 | (visit (basename name) result))) | |
116 | ||
117 | (define (down name stat result) | |
118 | (visit "." '())) | |
119 | ||
120 | (define (up name stat result) | |
121 | (visit ".." result)) | |
122 | ||
123 | (define (skip name stat result) | |
124 | ;; All the sub-directories are skipped. | |
125 | (visit (basename name) result)) | |
126 | ||
127 | (define (error name* stat errno result) | |
128 | (if (string=? name name*) ; top-level NAME is unreadable | |
129 | result | |
130 | (visit (basename name*) result))) | |
131 | ||
132 | (and=> (file-system-fold enter? leaf down up skip error #f name lstat) | |
133 | (lambda (files) | |
134 | (sort files entry<?)))) | |
135 | ||
136 | (match (scandir (dirname profile) | |
24e262f0 | 137 | (cute regexp-exec (profile-regexp profile) <>)) |
0afdc485 | 138 | (#f ; no profile directory |
9241172c | 139 | '(0)) |
0afdc485 | 140 | (() ; no profiles |
9241172c | 141 | '(0)) |
0afdc485 | 142 | ((profiles ...) ; former profiles around |
99882c61 LC |
143 | (sort (map (compose string->number |
144 | (cut match:substring <> 1) | |
145 | (cute regexp-exec (profile-regexp profile) <>)) | |
146 | profiles) | |
147 | <)))) | |
9241172c | 148 | |
1b0a8212 | 149 | (define (previous-generation-number profile number) |
9241172c LC |
150 | "Return the number of the generation before generation NUMBER of |
151 | PROFILE, or 0 if none exists. It could be NUMBER - 1, but it's not the | |
152 | case when generations have been deleted (there are \"holes\")." | |
153 | (fold (lambda (candidate highest) | |
154 | (if (and (< candidate number) (> candidate highest)) | |
155 | candidate | |
156 | highest)) | |
157 | 0 | |
1b0a8212 | 158 | (generation-numbers profile))) |
0afdc485 LC |
159 | |
160 | (define (profile-derivation store packages) | |
161 | "Return a derivation that builds a profile (a user environment) with | |
4dede022 | 162 | all of PACKAGES, a list of name/version/output/path/deps tuples." |
94a4b3b9 LC |
163 | (define packages* |
164 | ;; Turn any package object in PACKAGES into its output path. | |
165 | (map (match-lambda | |
166 | ((name version output path (deps ...)) | |
167 | `(,name ,version ,output ,path | |
168 | ,(map input->name+path deps)))) | |
169 | packages)) | |
170 | ||
0afdc485 LC |
171 | (define builder |
172 | `(begin | |
173 | (use-modules (ice-9 pretty-print) | |
174 | (guix build union)) | |
175 | ||
176 | (setvbuf (current-output-port) _IOLBF) | |
177 | (setvbuf (current-error-port) _IOLBF) | |
178 | ||
179 | (let ((output (assoc-ref %outputs "out")) | |
180 | (inputs (map cdr %build-inputs))) | |
181 | (format #t "building user environment `~a' with ~a packages...~%" | |
182 | output (length inputs)) | |
183 | (union-build output inputs) | |
184 | (call-with-output-file (string-append output "/manifest") | |
185 | (lambda (p) | |
4dede022 | 186 | (pretty-print '(manifest (version 1) |
94a4b3b9 | 187 | (packages ,packages*)) |
0afdc485 LC |
188 | p)))))) |
189 | ||
94a4b3b9 LC |
190 | (define ensure-valid-input |
191 | ;; If a package object appears in the given input, turn it into a | |
192 | ;; derivation path. | |
193 | (match-lambda | |
194 | ((name (? package? p) sub-drv ...) | |
195 | `(,name ,(package-derivation (%store) p) ,@sub-drv)) | |
196 | (input | |
197 | input))) | |
198 | ||
0afdc485 LC |
199 | (build-expression->derivation store "user-environment" |
200 | (%current-system) | |
201 | builder | |
4dede022 LC |
202 | (append-map (match-lambda |
203 | ((name version output path deps) | |
204 | `((,name ,path) | |
94a4b3b9 LC |
205 | ,@(map ensure-valid-input |
206 | deps)))) | |
4dede022 | 207 | packages) |
0afdc485 LC |
208 | #:modules '((guix build union)))) |
209 | ||
1b0a8212 | 210 | (define (generation-number profile) |
24e262f0 LC |
211 | "Return PROFILE's number or 0. An absolute file name must be used." |
212 | (or (and=> (false-if-exception (regexp-exec (profile-regexp profile) | |
213 | (basename (readlink profile)))) | |
214 | (compose string->number (cut match:substring <> 1))) | |
215 | 0)) | |
216 | ||
64d2e973 NK |
217 | (define (link-to-empty-profile generation) |
218 | "Link GENERATION, a string, to the empty profile." | |
219 | (let* ((drv (profile-derivation (%store) '())) | |
220 | (prof (derivation->output-path drv "out"))) | |
221 | (when (not (build-derivations (%store) (list drv))) | |
222 | (leave (_ "failed to build the empty profile~%"))) | |
223 | ||
224 | (switch-symlinks generation prof))) | |
225 | ||
b7884ca3 NK |
226 | (define (switch-to-previous-generation profile) |
227 | "Atomically switch PROFILE to the previous generation." | |
228 | (let* ((number (generation-number profile)) | |
229 | (previous-number (previous-generation-number profile number)) | |
230 | (previous-generation (format #f "~a-~a-link" | |
231 | profile previous-number))) | |
232 | (format #t (_ "switching from generation ~a to ~a~%") | |
233 | number previous-number) | |
234 | (switch-symlinks profile previous-generation))) | |
235 | ||
24e262f0 LC |
236 | (define (roll-back profile) |
237 | "Roll back to the previous generation of PROFILE." | |
1b0a8212 NK |
238 | (let* ((number (generation-number profile)) |
239 | (previous-number (previous-generation-number profile number)) | |
240 | (previous-generation (format #f "~a-~a-link" | |
241 | profile previous-number)) | |
242 | (manifest (string-append previous-generation "/manifest"))) | |
b7884ca3 NK |
243 | (cond ((not (file-exists? profile)) ; invalid profile |
244 | (leave (_ "profile '~a' does not exist~%") | |
a2011be5 | 245 | profile)) |
b7884ca3 | 246 | ((zero? number) ; empty profile |
c31d1a78 LC |
247 | (format (current-error-port) |
248 | (_ "nothing to do: already at the empty profile~%"))) | |
b7884ca3 | 249 | ((or (zero? previous-number) ; going to emptiness |
1b0a8212 | 250 | (not (file-exists? previous-generation))) |
64d2e973 | 251 | (link-to-empty-profile previous-generation) |
b7884ca3 NK |
252 | (switch-to-previous-generation profile)) |
253 | (else | |
254 | (switch-to-previous-generation profile))))) ; anything else | |
24e262f0 | 255 | |
2cd09108 NK |
256 | (define (generation-time profile number) |
257 | "Return the creation time of a generation in the UTC format." | |
258 | (make-time time-utc 0 | |
259 | (stat:ctime (stat (format #f "~a-~a-link" profile number))))) | |
260 | ||
d7ddb257 LC |
261 | (define* (matching-generations str #:optional (profile %current-profile) |
262 | #:key (duration-relation <=)) | |
2cd09108 | 263 | "Return the list of available generations matching a pattern in STR. See |
d7ddb257 LC |
264 | 'string->generations' and 'string->duration' for the list of valid patterns. |
265 | When STR is a duration pattern, return all the generations whose ctime has | |
266 | DURATION-RELATION with the current time." | |
2cd09108 NK |
267 | (define (valid-generations lst) |
268 | (define (valid-generation? n) | |
269 | (any (cut = n <>) (generation-numbers profile))) | |
270 | ||
271 | (fold-right (lambda (x acc) | |
272 | (if (valid-generation? x) | |
273 | (cons x acc) | |
274 | acc)) | |
275 | '() | |
276 | lst)) | |
277 | ||
278 | (define (filter-generations generations) | |
279 | (match generations | |
280 | (() '()) | |
281 | (('>= n) | |
282 | (drop-while (cut > n <>) | |
283 | (generation-numbers profile))) | |
284 | (('<= n) | |
285 | (valid-generations (iota n 1))) | |
286 | ((lst ..1) | |
287 | (valid-generations lst)) | |
288 | (_ #f))) | |
289 | ||
290 | (define (filter-by-duration duration) | |
291 | (define (time-at-midnight time) | |
292 | ;; Return TIME at midnight by setting nanoseconds, seconds, minutes, and | |
293 | ;; hours to zeros. | |
294 | (let ((d (time-utc->date time))) | |
295 | (date->time-utc | |
296 | (make-date 0 0 0 0 | |
297 | (date-day d) (date-month d) | |
298 | (date-year d) (date-zone-offset d))))) | |
299 | ||
300 | (define generation-ctime-alist | |
301 | (map (lambda (number) | |
302 | (cons number | |
303 | (time-second | |
304 | (time-at-midnight | |
305 | (generation-time profile number))))) | |
306 | (generation-numbers profile))) | |
307 | ||
308 | (match duration | |
309 | (#f #f) | |
310 | (res | |
311 | (let ((s (time-second | |
312 | (subtract-duration (time-at-midnight (current-time)) | |
313 | duration)))) | |
314 | (delete #f (map (lambda (x) | |
d7ddb257 | 315 | (and (duration-relation s (cdr x)) |
2cd09108 NK |
316 | (first x))) |
317 | generation-ctime-alist)))))) | |
318 | ||
319 | (cond ((string->generations str) | |
320 | => | |
321 | filter-generations) | |
322 | ((string->duration str) | |
323 | => | |
324 | filter-by-duration) | |
325 | (else #f))) | |
326 | ||
acc08466 NK |
327 | (define (find-packages-by-description rx) |
328 | "Search in SYNOPSIS and DESCRIPTION using RX. Return a list of | |
329 | matching packages." | |
330 | (define (same-location? p1 p2) | |
331 | ;; Compare locations of two packages. | |
332 | (equal? (package-location p1) (package-location p2))) | |
333 | ||
334 | (delete-duplicates | |
335 | (sort | |
336 | (fold-packages (lambda (package result) | |
337 | (define matches? | |
338 | (cut regexp-exec rx <>)) | |
339 | ||
340 | (if (or (and=> (package-synopsis package) | |
341 | (compose matches? gettext)) | |
342 | (and=> (package-description package) | |
343 | (compose matches? gettext))) | |
344 | (cons package result) | |
345 | result)) | |
346 | '()) | |
347 | (lambda (p1 p2) | |
348 | (string<? (package-name p1) | |
349 | (package-name p2)))) | |
350 | same-location?)) | |
351 | ||
4dede022 LC |
352 | (define (input->name+path input) |
353 | "Convert the name/package/sub-drv tuple INPUT to a name/store-path tuple." | |
354 | (let loop ((input input)) | |
355 | (match input | |
94a4b3b9 | 356 | ((name (? package? package)) |
4dede022 | 357 | (loop `(,name ,package "out"))) |
94a4b3b9 LC |
358 | ((name (? package? package) sub-drv) |
359 | `(,name ,(package-output (%store) package sub-drv))) | |
360 | (_ | |
361 | input)))) | |
4dede022 | 362 | |
b52cb20d LC |
363 | (define %sigint-prompt |
364 | ;; The prompt to jump to upon SIGINT. | |
365 | (make-prompt-tag "interruptible")) | |
366 | ||
367 | (define (call-with-sigint-handler thunk handler) | |
368 | "Call THUNK and return its value. Upon SIGINT, call HANDLER with the signal | |
369 | number in the context of the continuation of the call to this function, and | |
370 | return its return value." | |
371 | (call-with-prompt %sigint-prompt | |
372 | (lambda () | |
373 | (sigaction SIGINT | |
374 | (lambda (signum) | |
375 | (sigaction SIGINT SIG_DFL) | |
376 | (abort-to-prompt %sigint-prompt signum))) | |
90a1e4b3 LC |
377 | (dynamic-wind |
378 | (const #t) | |
379 | thunk | |
380 | (cut sigaction SIGINT SIG_DFL))) | |
b52cb20d LC |
381 | (lambda (k signum) |
382 | (handler signum)))) | |
383 | ||
ef010c0f LC |
384 | (define-syntax-rule (waiting exp fmt rest ...) |
385 | "Display the given message while EXP is being evaluated." | |
386 | (let* ((message (format #f fmt rest ...)) | |
387 | (blank (make-string (string-length message) #\space))) | |
388 | (display message (current-error-port)) | |
389 | (force-output (current-error-port)) | |
b52cb20d LC |
390 | (call-with-sigint-handler |
391 | (lambda () | |
91fe0e20 LC |
392 | (dynamic-wind |
393 | (const #f) | |
394 | (lambda () exp) | |
395 | (lambda () | |
396 | ;; Clear the line. | |
397 | (display #\cr (current-error-port)) | |
398 | (display blank (current-error-port)) | |
399 | (display #\cr (current-error-port)) | |
400 | (force-output (current-error-port))))) | |
b52cb20d LC |
401 | (lambda (signum) |
402 | (format (current-error-port) " interrupted by signal ~a~%" SIGINT) | |
403 | #f)))) | |
ef010c0f | 404 | |
e3ccdf9e LC |
405 | (define ftp-open* |
406 | ;; Memoizing version of `ftp-open'. The goal is to avoid initiating a new | |
407 | ;; FTP connection for each package, esp. since most of them are to the same | |
408 | ;; server. This has a noticeable impact when doing "guix upgrade -u". | |
409 | (memoize ftp-open)) | |
410 | ||
ef010c0f LC |
411 | (define (check-package-freshness package) |
412 | "Check whether PACKAGE has a newer version available upstream, and report | |
413 | it." | |
414 | ;; TODO: Automatically inject the upstream version when desired. | |
19777ae6 LC |
415 | |
416 | (catch #t | |
417 | (lambda () | |
993fb66d | 418 | (when (false-if-exception (gnu-package? package)) |
19777ae6 LC |
419 | (let ((name (package-name package)) |
420 | (full-name (package-full-name package))) | |
e3ccdf9e LC |
421 | (match (waiting (latest-release name |
422 | #:ftp-open ftp-open* | |
423 | #:ftp-close (const #f)) | |
19777ae6 LC |
424 | (_ "looking for the latest release of GNU ~a...") name) |
425 | ((latest-version . _) | |
426 | (when (version>? latest-version full-name) | |
427 | (format (current-error-port) | |
428 | (_ "~a: note: using ~a \ | |
ef010c0f | 429 | but ~a is available upstream~%") |
19777ae6 LC |
430 | (location->string (package-location package)) |
431 | full-name latest-version))) | |
432 | (_ #t))))) | |
433 | (lambda (key . args) | |
434 | ;; Silently ignore networking errors rather than preventing | |
435 | ;; installation. | |
436 | (case key | |
437 | ((getaddrinfo-error ftp-error) #f) | |
438 | (else (apply throw key args)))))) | |
ef010c0f | 439 | |
5924080d LC |
440 | (define* (search-path-environment-variables packages profile |
441 | #:optional (getenv getenv)) | |
442 | "Return environment variable definitions that may be needed for the use of | |
443 | PACKAGES in PROFILE. Use GETENV to determine the current settings and report | |
444 | only settings not already effective." | |
445 | ||
a81bc531 LC |
446 | ;; Prefer ~/.guix-profile to the real profile directory name. |
447 | (let ((profile (if (and %user-environment-directory | |
448 | (false-if-exception | |
449 | (string=? (readlink %user-environment-directory) | |
450 | profile))) | |
451 | %user-environment-directory | |
452 | profile))) | |
453 | ||
454 | ;; The search path info is not stored in the manifest. Thus, we infer the | |
455 | ;; search paths from same-named packages found in the distro. | |
456 | ||
457 | (define package-in-manifest->package | |
458 | (match-lambda | |
459 | ((name version _ ...) | |
460 | (match (append (find-packages-by-name name version) | |
461 | (find-packages-by-name name)) | |
462 | ((p _ ...) p) | |
463 | (_ #f))))) | |
464 | ||
465 | (define search-path-definition | |
466 | (match-lambda | |
467 | (($ <search-path-specification> variable directories separator) | |
468 | (let ((values (or (and=> (getenv variable) | |
469 | (cut string-tokenize* <> separator)) | |
470 | '())) | |
471 | (directories (filter file-exists? | |
472 | (map (cut string-append profile | |
473 | "/" <>) | |
474 | directories)))) | |
475 | (if (every (cut member <> values) directories) | |
476 | #f | |
477 | (format #f "export ~a=\"~a\"" | |
478 | variable | |
479 | (string-join directories separator))))))) | |
480 | ||
481 | (let* ((packages (filter-map package-in-manifest->package packages)) | |
482 | (search-paths (delete-duplicates | |
483 | (append-map package-native-search-paths | |
484 | packages)))) | |
485 | (filter-map search-path-definition search-paths)))) | |
5924080d LC |
486 | |
487 | (define (display-search-paths packages profile) | |
488 | "Display the search path environment variables that may need to be set for | |
489 | PACKAGES, in the context of PROFILE." | |
490 | (let ((settings (search-path-environment-variables packages profile))) | |
491 | (unless (null? settings) | |
492 | (format #t (_ "The following environment variable definitions may be needed:~%")) | |
a81bc531 | 493 | (format #t "~{ ~a~%~}" settings)))) |
5924080d | 494 | |
0afdc485 LC |
495 | \f |
496 | ;;; | |
497 | ;;; Command-line options. | |
498 | ;;; | |
499 | ||
500 | (define %default-options | |
501 | ;; Alist of default option values. | |
3b824605 | 502 | `((profile . ,%current-profile) |
969e678e | 503 | (max-silent-time . 3600) |
3b824605 | 504 | (substitutes? . #t))) |
0afdc485 | 505 | |
0afdc485 | 506 | (define (show-help) |
e49951eb | 507 | (display (_ "Usage: guix package [OPTION]... PACKAGES... |
0afdc485 LC |
508 | Install, remove, or upgrade PACKAGES in a single transaction.\n")) |
509 | (display (_ " | |
510 | -i, --install=PACKAGE install PACKAGE")) | |
511 | (display (_ " | |
5d4b411f LC |
512 | -e, --install-from-expression=EXP |
513 | install the package EXP evaluates to")) | |
514 | (display (_ " | |
0afdc485 LC |
515 | -r, --remove=PACKAGE remove PACKAGE")) |
516 | (display (_ " | |
acb6ba25 | 517 | -u, --upgrade[=REGEXP] upgrade all the installed packages matching REGEXP")) |
24e262f0 LC |
518 | (display (_ " |
519 | --roll-back roll back to the previous generation")) | |
5924080d LC |
520 | (display (_ " |
521 | --search-paths display needed environment variable definitions")) | |
2cd09108 NK |
522 | (display (_ " |
523 | -l, --list-generations[=PATTERN] | |
524 | list generations matching PATTERN")) | |
b7884ca3 NK |
525 | (display (_ " |
526 | -d, --delete-generations[=PATTERN] | |
527 | delete generations matching PATTERN")) | |
0afdc485 LC |
528 | (newline) |
529 | (display (_ " | |
530 | -p, --profile=PROFILE use PROFILE instead of the user's default profile")) | |
531 | (display (_ " | |
532 | -n, --dry-run show what would be done without actually doing it")) | |
56b1f4b7 LC |
533 | (display (_ " |
534 | --fallback fall back to building when the substituter fails")) | |
3b824605 LC |
535 | (display (_ " |
536 | --no-substitutes build instead of resorting to pre-built substitutes")) | |
969e678e LC |
537 | (display (_ " |
538 | --max-silent-time=SECONDS | |
539 | mark the build as failed after SECONDS of silence")) | |
0afdc485 | 540 | (display (_ " |
cc57f25d | 541 | --bootstrap use the bootstrap Guile to build the profile")) |
70915c1a LC |
542 | (display (_ " |
543 | --verbose produce verbose output")) | |
0afdc485 LC |
544 | (newline) |
545 | (display (_ " | |
acc08466 NK |
546 | -s, --search=REGEXP search in synopsis and description using REGEXP")) |
547 | (display (_ " | |
733b4130 LC |
548 | -I, --list-installed[=REGEXP] |
549 | list installed packages matching REGEXP")) | |
64fc89b6 LC |
550 | (display (_ " |
551 | -A, --list-available[=REGEXP] | |
552 | list available packages matching REGEXP")) | |
733b4130 LC |
553 | (newline) |
554 | (display (_ " | |
0afdc485 LC |
555 | -h, --help display this help and exit")) |
556 | (display (_ " | |
557 | -V, --version display version information and exit")) | |
558 | (newline) | |
3441e164 | 559 | (show-bug-report-information)) |
0afdc485 LC |
560 | |
561 | (define %options | |
562 | ;; Specification of the command-line options. | |
563 | (list (option '(#\h "help") #f #f | |
564 | (lambda args | |
565 | (show-help) | |
566 | (exit 0))) | |
567 | (option '(#\V "version") #f #f | |
568 | (lambda args | |
fdca1c07 | 569 | (show-version-and-exit "guix package"))) |
0afdc485 LC |
570 | |
571 | (option '(#\i "install") #t #f | |
572 | (lambda (opt name arg result) | |
573 | (alist-cons 'install arg result))) | |
5d4b411f LC |
574 | (option '(#\e "install-from-expression") #t #f |
575 | (lambda (opt name arg result) | |
576 | (alist-cons 'install (read/eval-package-expression arg) | |
577 | result))) | |
0afdc485 LC |
578 | (option '(#\r "remove") #t #f |
579 | (lambda (opt name arg result) | |
580 | (alist-cons 'remove arg result))) | |
acb6ba25 | 581 | (option '(#\u "upgrade") #f #t |
dc5669cd MW |
582 | (lambda (opt name arg result) |
583 | (alist-cons 'upgrade arg result))) | |
24e262f0 LC |
584 | (option '("roll-back") #f #f |
585 | (lambda (opt name arg result) | |
586 | (alist-cons 'roll-back? #t result))) | |
2cd09108 NK |
587 | (option '(#\l "list-generations") #f #t |
588 | (lambda (opt name arg result) | |
589 | (cons `(query list-generations ,(or arg "")) | |
590 | result))) | |
b7884ca3 NK |
591 | (option '(#\d "delete-generations") #f #t |
592 | (lambda (opt name arg result) | |
593 | (alist-cons 'delete-generations (or arg "") | |
594 | result))) | |
5924080d LC |
595 | (option '("search-paths") #f #f |
596 | (lambda (opt name arg result) | |
597 | (cons `(query search-paths) result))) | |
0afdc485 LC |
598 | (option '(#\p "profile") #t #f |
599 | (lambda (opt name arg result) | |
600 | (alist-cons 'profile arg | |
601 | (alist-delete 'profile result)))) | |
602 | (option '(#\n "dry-run") #f #f | |
603 | (lambda (opt name arg result) | |
604 | (alist-cons 'dry-run? #t result))) | |
56b1f4b7 LC |
605 | (option '("fallback") #f #f |
606 | (lambda (opt name arg result) | |
607 | (alist-cons 'fallback? #t | |
608 | (alist-delete 'fallback? result)))) | |
3b824605 LC |
609 | (option '("no-substitutes") #f #f |
610 | (lambda (opt name arg result) | |
611 | (alist-cons 'substitutes? #f | |
612 | (alist-delete 'substitutes? result)))) | |
969e678e LC |
613 | (option '("max-silent-time") #t #f |
614 | (lambda (opt name arg result) | |
615 | (alist-cons 'max-silent-time (string->number* arg) | |
616 | result))) | |
cc57f25d | 617 | (option '("bootstrap") #f #f |
0afdc485 | 618 | (lambda (opt name arg result) |
733b4130 | 619 | (alist-cons 'bootstrap? #t result))) |
70915c1a LC |
620 | (option '("verbose") #f #f |
621 | (lambda (opt name arg result) | |
622 | (alist-cons 'verbose? #t result))) | |
acc08466 NK |
623 | (option '(#\s "search") #t #f |
624 | (lambda (opt name arg result) | |
625 | (cons `(query search ,(or arg "")) | |
626 | result))) | |
733b4130 LC |
627 | (option '(#\I "list-installed") #f #t |
628 | (lambda (opt name arg result) | |
629 | (cons `(query list-installed ,(or arg "")) | |
64fc89b6 LC |
630 | result))) |
631 | (option '(#\A "list-available") #f #t | |
632 | (lambda (opt name arg result) | |
633 | (cons `(query list-available ,(or arg "")) | |
733b4130 | 634 | result))))) |
0afdc485 LC |
635 | |
636 | \f | |
637 | ;;; | |
638 | ;;; Entry point. | |
639 | ;;; | |
640 | ||
641 | (define (guix-package . args) | |
642 | (define (parse-options) | |
643 | ;; Return the alist of option values. | |
a5975ced LC |
644 | (args-fold* args %options |
645 | (lambda (opt name arg result) | |
646 | (leave (_ "~A: unrecognized option~%") name)) | |
647 | (lambda (arg result) | |
648 | (leave (_ "~A: extraneous argument~%") arg)) | |
649 | %default-options)) | |
0afdc485 | 650 | |
9762706b LC |
651 | (define (guile-missing?) |
652 | ;; Return #t if %GUILE-FOR-BUILD is not available yet. | |
59688fc4 | 653 | (let ((out (derivation->output-path (%guile-for-build)))) |
c4d64534 | 654 | (not (valid-path? (%store) out)))) |
9762706b | 655 | |
dc5669cd MW |
656 | (define newest-available-packages |
657 | (memoize find-newest-available-packages)) | |
658 | ||
659 | (define (find-best-packages-by-name name version) | |
660 | (if version | |
661 | (find-packages-by-name name version) | |
662 | (match (vhash-assoc name (newest-available-packages)) | |
663 | ((_ version pkgs ...) pkgs) | |
664 | (#f '())))) | |
665 | ||
ce3b7a61 | 666 | (define* (find-package name #:optional (output "out")) |
0afdc485 | 667 | ;; Find the package NAME; NAME may contain a version number and a |
dc5669cd | 668 | ;; sub-derivation name. If the version number is not present, |
ce3b7a61 LC |
669 | ;; return the preferred newest version. If the sub-derivation name is not |
670 | ;; present, use OUTPUT. | |
0afdc485 | 671 | (define request name) |
0afdc485 | 672 | |
aa92cf98 LC |
673 | (define (ensure-output p sub-drv) |
674 | (if (member sub-drv (package-outputs p)) | |
675 | p | |
98eb8cbe | 676 | (leave (_ "package `~a' lacks output `~a'~%") |
aa92cf98 LC |
677 | (package-full-name p) |
678 | sub-drv))) | |
679 | ||
0afdc485 LC |
680 | (let*-values (((name sub-drv) |
681 | (match (string-rindex name #\:) | |
ce3b7a61 | 682 | (#f (values name output)) |
9518856b LC |
683 | (colon (values (substring name 0 colon) |
684 | (substring name (+ 1 colon)))))) | |
0afdc485 | 685 | ((name version) |
9b48fb88 | 686 | (package-name->name+version name))) |
dc5669cd | 687 | (match (find-best-packages-by-name name version) |
0afdc485 | 688 | ((p) |
4dede022 LC |
689 | (list name (package-version p) sub-drv (ensure-output p sub-drv) |
690 | (package-transitive-propagated-inputs p))) | |
c6f09dfa | 691 | ((p p* ...) |
a2011be5 LC |
692 | (warning (_ "ambiguous package specification `~a'~%") |
693 | request) | |
694 | (warning (_ "choosing ~a from ~a~%") | |
695 | (package-full-name p) | |
696 | (location->string (package-location p))) | |
4dede022 LC |
697 | (list name (package-version p) sub-drv (ensure-output p sub-drv) |
698 | (package-transitive-propagated-inputs p))) | |
0afdc485 LC |
699 | (() |
700 | (leave (_ "~a: package not found~%") request))))) | |
701 | ||
dc5669cd MW |
702 | (define (upgradeable? name current-version current-path) |
703 | ;; Return #t if there's a version of package NAME newer than | |
704 | ;; CURRENT-VERSION, or if the newest available version is equal to | |
705 | ;; CURRENT-VERSION but would have an output path different than | |
706 | ;; CURRENT-PATH. | |
707 | (match (vhash-assoc name (newest-available-packages)) | |
708 | ((_ candidate-version pkg . rest) | |
709 | (case (version-compare candidate-version current-version) | |
710 | ((>) #t) | |
711 | ((<) #f) | |
59688fc4 | 712 | ((=) (let ((candidate-path (derivation->output-path |
dc5669cd MW |
713 | (package-derivation (%store) pkg)))) |
714 | (not (string=? current-path candidate-path)))))) | |
715 | (#f #f))) | |
716 | ||
0ec1af59 | 717 | (define (ensure-default-profile) |
70c43291 LC |
718 | ;; Ensure the default profile symlink and directory exist and are |
719 | ;; writable. | |
720 | ||
721 | (define (rtfm) | |
722 | (format (current-error-port) | |
723 | (_ "Try \"info '(guix) Invoking guix package'\" for \ | |
724 | more information.~%")) | |
725 | (exit 1)) | |
0ec1af59 LC |
726 | |
727 | ;; Create ~/.guix-profile if it doesn't exist yet. | |
728 | (when (and %user-environment-directory | |
729 | %current-profile | |
730 | (not (false-if-exception | |
731 | (lstat %user-environment-directory)))) | |
732 | (symlink %current-profile %user-environment-directory)) | |
733 | ||
70c43291 LC |
734 | (let ((s (stat %profile-directory #f))) |
735 | ;; Attempt to create /…/profiles/per-user/$USER if needed. | |
736 | (unless (and s (eq? 'directory (stat:type s))) | |
737 | (catch 'system-error | |
738 | (lambda () | |
739 | (mkdir-p %profile-directory)) | |
740 | (lambda args | |
741 | ;; Often, we cannot create %PROFILE-DIRECTORY because its | |
742 | ;; parent directory is root-owned and we're running | |
743 | ;; unprivileged. | |
744 | (format (current-error-port) | |
745 | (_ "error: while creating directory `~a': ~a~%") | |
746 | %profile-directory | |
747 | (strerror (system-error-errno args))) | |
748 | (format (current-error-port) | |
749 | (_ "Please create the `~a' directory, with you as the owner.~%") | |
750 | %profile-directory) | |
751 | (rtfm)))) | |
752 | ||
753 | ;; Bail out if it's not owned by the user. | |
cba363be | 754 | (unless (or (not s) (= (stat:uid s) (getuid))) |
70c43291 LC |
755 | (format (current-error-port) |
756 | (_ "error: directory `~a' is not owned by you~%") | |
757 | %profile-directory) | |
758 | (format (current-error-port) | |
759 | (_ "Please change the owner of `~a' to user ~s.~%") | |
760 | %profile-directory (or (getenv "USER") (getuid))) | |
761 | (rtfm)))) | |
0ec1af59 | 762 | |
733b4130 LC |
763 | (define (process-actions opts) |
764 | ;; Process any install/remove/upgrade action from OPTS. | |
24e262f0 LC |
765 | |
766 | (define dry-run? (assoc-ref opts 'dry-run?)) | |
767 | (define verbose? (assoc-ref opts 'verbose?)) | |
768 | (define profile (assoc-ref opts 'profile)) | |
769 | ||
4dede022 LC |
770 | (define (canonicalize-deps deps) |
771 | ;; Remove duplicate entries from DEPS, a list of propagated inputs, | |
772 | ;; where each input is a name/path tuple. | |
773 | (define (same? d1 d2) | |
774 | (match d1 | |
94a4b3b9 LC |
775 | ((_ p1) |
776 | (match d2 | |
777 | ((_ p2) (eq? p1 p2)) | |
778 | (_ #f))) | |
779 | ((_ p1 out1) | |
4dede022 | 780 | (match d2 |
94a4b3b9 LC |
781 | ((_ p2 out2) |
782 | (and (string=? out1 out2) | |
783 | (eq? p1 p2))) | |
784 | (_ #f))))) | |
4dede022 | 785 | |
94a4b3b9 | 786 | (delete-duplicates deps same?)) |
4dede022 | 787 | |
079d1273 LC |
788 | (define (same-package? tuple name out) |
789 | (match tuple | |
790 | ((tuple-name _ tuple-output _ ...) | |
791 | (and (equal? name tuple-name) | |
792 | (equal? out tuple-output))))) | |
793 | ||
5d4b411f | 794 | (define (package->tuple p) |
741c70c6 LC |
795 | ;; Convert package P to a tuple. |
796 | ;; When given a package via `-e', install the first of its | |
797 | ;; outputs (XXX). | |
798 | (let* ((out (car (package-outputs p))) | |
799 | (path (package-output (%store) p out)) | |
800 | (deps (package-transitive-propagated-inputs p))) | |
5d4b411f LC |
801 | `(,(package-name p) |
802 | ,(package-version p) | |
741c70c6 | 803 | ,out |
2096b516 | 804 | ,p |
5d4b411f LC |
805 | ,(canonicalize-deps deps)))) |
806 | ||
a4f08f92 LC |
807 | (define (show-what-to-remove/install remove install dry-run?) |
808 | ;; Tell the user what's going to happen in high-level terms. | |
809 | ;; TODO: Report upgrades more clearly. | |
810 | (match remove | |
811 | (((name version _ path _) ..1) | |
812 | (let ((len (length name)) | |
813 | (remove (map (cut format #f " ~a-~a\t~a" <> <> <>) | |
814 | name version path))) | |
815 | (if dry-run? | |
816 | (format (current-error-port) | |
817 | (N_ "The following package would be removed:~% ~{~a~%~}~%" | |
818 | "The following packages would be removed:~% ~{~a~%~}~%" | |
819 | len) | |
820 | remove) | |
821 | (format (current-error-port) | |
822 | (N_ "The following package will be removed:~% ~{~a~%~}~%" | |
823 | "The following packages will be removed:~% ~{~a~%~}~%" | |
824 | len) | |
825 | remove)))) | |
826 | (_ #f)) | |
827 | (match install | |
a2ed7389 | 828 | (((name version output path _) ..1) |
a4f08f92 | 829 | (let ((len (length name)) |
a2ed7389 LC |
830 | (install (map (cut format #f " ~a-~a\t~a\t~a" <> <> <> <>) |
831 | name version output path))) | |
a4f08f92 LC |
832 | (if dry-run? |
833 | (format (current-error-port) | |
15f67744 LC |
834 | (N_ "The following package would be installed:~%~{~a~%~}~%" |
835 | "The following packages would be installed:~%~{~a~%~}~%" | |
a4f08f92 LC |
836 | len) |
837 | install) | |
838 | (format (current-error-port) | |
15f67744 LC |
839 | (N_ "The following package will be installed:~%~{~a~%~}~%" |
840 | "The following packages will be installed:~%~{~a~%~}~%" | |
a4f08f92 LC |
841 | len) |
842 | install)))) | |
843 | (_ #f))) | |
844 | ||
b7884ca3 NK |
845 | (define current-generation-number |
846 | (generation-number profile)) | |
847 | ||
848 | (define (display-and-delete number) | |
849 | (let ((generation (format #f "~a-~a-link" profile number))) | |
850 | (unless (zero? number) | |
851 | (format #t (_ "deleting ~a~%") generation) | |
852 | (delete-file generation)))) | |
853 | ||
854 | (define (delete-generation number) | |
855 | (let* ((previous-number (previous-generation-number profile number)) | |
856 | (previous-generation (format #f "~a-~a-link" | |
857 | profile previous-number))) | |
858 | (cond ((zero? number)) ; do not delete generation 0 | |
859 | ((and (= number current-generation-number) | |
860 | (not (file-exists? previous-generation))) | |
861 | (link-to-empty-profile previous-generation) | |
862 | (switch-to-previous-generation profile) | |
863 | (display-and-delete number)) | |
864 | ((= number current-generation-number) | |
865 | (roll-back profile) | |
866 | (display-and-delete number)) | |
867 | (else | |
868 | (display-and-delete number))))) | |
869 | ||
24e262f0 | 870 | ;; First roll back if asked to. |
b7884ca3 NK |
871 | (cond ((and (assoc-ref opts 'roll-back?) (not dry-run?)) |
872 | (begin | |
873 | (roll-back profile) | |
874 | (process-actions (alist-delete 'roll-back? opts)))) | |
875 | ((and (assoc-ref opts 'delete-generations) | |
876 | (not dry-run?)) | |
877 | (filter-map | |
878 | (match-lambda | |
879 | (('delete-generations . pattern) | |
880 | (cond ((not (file-exists? profile)) ; XXX: race condition | |
881 | (leave (_ "profile '~a' does not exist~%") | |
882 | profile)) | |
883 | ((string-null? pattern) | |
884 | (let ((numbers (generation-numbers profile))) | |
885 | (if (equal? numbers '(0)) | |
886 | (exit 0) | |
887 | (for-each display-and-delete | |
888 | (delete current-generation-number | |
889 | numbers))))) | |
890 | ;; Do not delete the zeroth generation. | |
891 | ((equal? 0 (string->number pattern)) | |
892 | (exit 0)) | |
d7ddb257 LC |
893 | |
894 | ;; If PATTERN is a duration, match generations that are | |
895 | ;; older than the specified duration. | |
896 | ((matching-generations pattern profile | |
897 | #:duration-relation >) | |
b7884ca3 NK |
898 | => |
899 | (lambda (numbers) | |
900 | (if (null-list? numbers) | |
901 | (exit 1) | |
902 | (for-each delete-generation numbers)))) | |
903 | (else | |
904 | (leave (_ "invalid syntax: ~a~%") | |
905 | pattern))) | |
906 | ||
907 | (process-actions | |
908 | (alist-delete 'delete-generations opts))) | |
909 | (_ #f)) | |
910 | opts)) | |
911 | (else | |
912 | (let* ((installed (manifest-packages (profile-manifest profile))) | |
913 | (upgrade-regexps (filter-map (match-lambda | |
914 | (('upgrade . regexp) | |
915 | (make-regexp (or regexp ""))) | |
916 | (_ #f)) | |
917 | opts)) | |
918 | (upgrade (if (null? upgrade-regexps) | |
919 | '() | |
920 | (let ((newest (find-newest-available-packages))) | |
921 | (filter-map | |
922 | (match-lambda | |
923 | ((name version output path _) | |
924 | (and (any (cut regexp-exec <> name) | |
925 | upgrade-regexps) | |
926 | (upgradeable? name version path) | |
927 | (find-package name | |
928 | (or output "out")))) | |
929 | (_ #f)) | |
930 | installed)))) | |
931 | (install (append | |
932 | upgrade | |
933 | (filter-map (match-lambda | |
934 | (('install . (? package? p)) | |
935 | (package->tuple p)) | |
936 | (('install . (? store-path?)) | |
937 | #f) | |
938 | (('install . package) | |
939 | (find-package package)) | |
940 | (_ #f)) | |
941 | opts))) | |
942 | (drv (filter-map (match-lambda | |
943 | ((name version sub-drv | |
944 | (? package? package) | |
945 | (deps ...)) | |
946 | (check-package-freshness package) | |
947 | (package-derivation (%store) package)) | |
948 | (_ #f)) | |
949 | install)) | |
950 | (install* | |
951 | (append | |
952 | (filter-map (match-lambda | |
953 | (('install . (? package? p)) | |
954 | #f) | |
955 | (('install . (? store-path? path)) | |
956 | (let-values (((name version) | |
957 | (package-name->name+version | |
958 | (store-path-package-name | |
959 | path)))) | |
960 | `(,name ,version #f ,path ()))) | |
961 | (_ #f)) | |
962 | opts) | |
963 | (map (lambda (tuple drv) | |
964 | (match tuple | |
965 | ((name version sub-drv _ (deps ...)) | |
966 | (let ((output-path | |
967 | (derivation->output-path | |
968 | drv sub-drv))) | |
969 | `(,name ,version ,sub-drv ,output-path | |
970 | ,(canonicalize-deps deps)))))) | |
971 | install drv))) | |
972 | (remove (filter-map (match-lambda | |
973 | (('remove . package) | |
974 | package) | |
975 | (_ #f)) | |
976 | opts)) | |
977 | (remove* (filter-map (cut assoc <> installed) remove)) | |
978 | (packages | |
979 | (append install* | |
980 | (fold (lambda (package result) | |
981 | (match package | |
982 | ((name _ out _ ...) | |
983 | (filter (negate | |
984 | (cut same-package? <> | |
985 | name out)) | |
986 | result)))) | |
987 | (fold alist-delete installed remove) | |
988 | install*)))) | |
24e262f0 LC |
989 | |
990 | (when (equal? profile %current-profile) | |
991 | (ensure-default-profile)) | |
992 | ||
a4f08f92 | 993 | (show-what-to-remove/install remove* install* dry-run?) |
dd36b51b LC |
994 | (show-what-to-build (%store) drv |
995 | #:use-substitutes? (assoc-ref opts 'substitutes?) | |
996 | #:dry-run? dry-run?) | |
24e262f0 LC |
997 | |
998 | (or dry-run? | |
999 | (and (build-derivations (%store) drv) | |
1000 | (let* ((prof-drv (profile-derivation (%store) packages)) | |
59688fc4 | 1001 | (prof (derivation->output-path prof-drv)) |
24e262f0 LC |
1002 | (old-drv (profile-derivation |
1003 | (%store) (manifest-packages | |
1004 | (profile-manifest profile)))) | |
59688fc4 | 1005 | (old-prof (derivation->output-path old-drv)) |
1b0a8212 | 1006 | (number (generation-number profile)) |
82fe08ed LC |
1007 | |
1008 | ;; Always use NUMBER + 1 for the new profile, | |
1009 | ;; possibly overwriting a "previous future | |
1010 | ;; generation". | |
1011 | (name (format #f "~a-~a-link" | |
1012 | profile (+ 1 number)))) | |
24e262f0 LC |
1013 | (if (string=? old-prof prof) |
1014 | (when (or (pair? install) (pair? remove)) | |
1015 | (format (current-error-port) | |
1016 | (_ "nothing to be done~%"))) | |
1017 | (and (parameterize ((current-build-output-port | |
1018 | ;; Output something when Guile | |
1019 | ;; needs to be built. | |
1020 | (if (or verbose? (guile-missing?)) | |
1021 | (current-error-port) | |
1022 | (%make-void-port "w")))) | |
1023 | (build-derivations (%store) (list prof-drv))) | |
fe1818e2 | 1024 | (let ((count (length packages))) |
82fe08ed | 1025 | (switch-symlinks name prof) |
5924080d | 1026 | (switch-symlinks profile name) |
fe1818e2 LC |
1027 | (format #t (N_ "~a package in profile~%" |
1028 | "~a packages in profile~%" | |
1029 | count) | |
1030 | count) | |
5924080d | 1031 | (display-search-paths packages |
b7884ca3 | 1032 | profile))))))))))) |
733b4130 LC |
1033 | |
1034 | (define (process-query opts) | |
1035 | ;; Process any query specified by OPTS. Return #t when a query was | |
1036 | ;; actually processed, #f otherwise. | |
1037 | (let ((profile (assoc-ref opts 'profile))) | |
1038 | (match (assoc-ref opts 'query) | |
2cd09108 NK |
1039 | (('list-generations pattern) |
1040 | (define (list-generation number) | |
4b2bc804 | 1041 | (unless (zero? number) |
9ac9360d NK |
1042 | (let ((header (format #f (_ "Generation ~a\t~a") number |
1043 | (date->string | |
1044 | (time-utc->date | |
1045 | (generation-time profile number)) | |
1046 | "~b ~d ~Y ~T"))) | |
1047 | (current (generation-number profile))) | |
1048 | (if (= number current) | |
1049 | (format #t (_ "~a\t(current)~%") header) | |
1050 | (format #t "~a~%" header))) | |
2cd09108 NK |
1051 | (for-each (match-lambda |
1052 | ((name version output location _) | |
1053 | (format #t " ~a\t~a\t~a\t~a~%" | |
1054 | name version output location))) | |
bd9bde1c LC |
1055 | |
1056 | ;; Show most recently installed packages last. | |
1057 | (reverse | |
1058 | (manifest-packages | |
1059 | (profile-manifest | |
1060 | (format #f "~a-~a-link" profile number))))) | |
2cd09108 NK |
1061 | (newline))) |
1062 | ||
1063 | (cond ((not (file-exists? profile)) ; XXX: race condition | |
1064 | (leave (_ "profile '~a' does not exist~%") | |
1065 | profile)) | |
1066 | ((string-null? pattern) | |
0ab212b9 NK |
1067 | (let ((numbers (generation-numbers profile))) |
1068 | (if (equal? numbers '(0)) | |
4658b2c4 | 1069 | (exit 0) |
0ab212b9 | 1070 | (for-each list-generation numbers)))) |
2cd09108 NK |
1071 | ((matching-generations pattern profile) |
1072 | => | |
0ab212b9 NK |
1073 | (lambda (numbers) |
1074 | (if (null-list? numbers) | |
1075 | (exit 1) | |
1076 | (for-each list-generation numbers)))) | |
2cd09108 NK |
1077 | (else |
1078 | (leave (_ "invalid syntax: ~a~%") | |
1079 | pattern))) | |
1080 | #t) | |
1081 | ||
733b4130 LC |
1082 | (('list-installed regexp) |
1083 | (let* ((regexp (and regexp (make-regexp regexp))) | |
1084 | (manifest (profile-manifest profile)) | |
1085 | (installed (manifest-packages manifest))) | |
1086 | (for-each (match-lambda | |
4dede022 | 1087 | ((name version output path _) |
733b4130 LC |
1088 | (when (or (not regexp) |
1089 | (regexp-exec regexp name)) | |
1090 | (format #t "~a\t~a\t~a\t~a~%" | |
1091 | name (or version "?") output path)))) | |
bd9bde1c LC |
1092 | |
1093 | ;; Show most recently installed packages last. | |
1094 | (reverse installed)) | |
64fc89b6 | 1095 | #t)) |
acc08466 | 1096 | |
64fc89b6 LC |
1097 | (('list-available regexp) |
1098 | (let* ((regexp (and regexp (make-regexp regexp))) | |
1099 | (available (fold-packages | |
1100 | (lambda (p r) | |
1101 | (let ((n (package-name p))) | |
1102 | (if regexp | |
1103 | (if (regexp-exec regexp n) | |
1104 | (cons p r) | |
1105 | r) | |
1106 | (cons p r)))) | |
1107 | '()))) | |
1108 | (for-each (lambda (p) | |
44b6be77 | 1109 | (format #t "~a\t~a\t~a\t~a~%" |
64fc89b6 LC |
1110 | (package-name p) |
1111 | (package-version p) | |
44b6be77 | 1112 | (string-join (package-outputs p) ",") |
64fc89b6 LC |
1113 | (location->string (package-location p)))) |
1114 | (sort available | |
1115 | (lambda (p1 p2) | |
1116 | (string<? (package-name p1) | |
1117 | (package-name p2))))) | |
1118 | #t)) | |
acc08466 NK |
1119 | |
1120 | (('search regexp) | |
cb09fb24 | 1121 | (let ((regexp (make-regexp regexp regexp/icase))) |
299112d3 | 1122 | (for-each (cute package->recutils <> (current-output-port)) |
acc08466 NK |
1123 | (find-packages-by-description regexp)) |
1124 | #t)) | |
5924080d LC |
1125 | |
1126 | (('search-paths) | |
1127 | (let* ((manifest (profile-manifest profile)) | |
1128 | (packages (manifest-packages manifest)) | |
1129 | (settings (search-path-environment-variables packages | |
1130 | profile | |
1131 | (const #f)))) | |
1132 | (format #t "~{~a~%~}" settings) | |
1133 | #t)) | |
1134 | ||
733b4130 LC |
1135 | (_ #f)))) |
1136 | ||
0afdc485 | 1137 | (let ((opts (parse-options))) |
0f5378eb | 1138 | (or (process-query opts) |
ef86c39f LC |
1139 | (with-error-handling |
1140 | (parameterize ((%store (open-connection))) | |
3b824605 | 1141 | (set-build-options (%store) |
56b1f4b7 | 1142 | #:fallback? (assoc-ref opts 'fallback?) |
3b824605 | 1143 | #:use-substitutes? |
969e678e LC |
1144 | (assoc-ref opts 'substitutes?) |
1145 | #:max-silent-time | |
1146 | (assoc-ref opts 'max-silent-time)) | |
3b824605 | 1147 | |
c4d64534 LC |
1148 | (parameterize ((%guile-for-build |
1149 | (package-derivation (%store) | |
1150 | (if (assoc-ref opts 'bootstrap?) | |
1151 | %bootstrap-guile | |
1152 | guile-final)))) | |
1153 | (process-actions opts))))))) |