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