Commit | Line | Data |
---|---|---|
0afdc485 LC |
1 | #!/bin/sh |
2 | # aside from this initial boilerplate, this is actually -*- scheme -*- code | |
3 | ||
4 | prefix="@prefix@" | |
5 | datarootdir="@datarootdir@" | |
6 | ||
7 | GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH" | |
8 | export GUILE_LOAD_COMPILED_PATH | |
9 | ||
10 | main='(module-ref (resolve-interface '\''(guix-package)) '\'guix-package')' | |
11 | exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \ | |
12 | -c "(apply $main (cdr (command-line)))" "$@" | |
13 | !# | |
233e7676 LC |
14 | ;;; GNU Guix --- Functional package management for GNU |
15 | ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> | |
24e262f0 | 16 | ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> |
dc5669cd | 17 | ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> |
0afdc485 | 18 | ;;; |
233e7676 | 19 | ;;; This file is part of GNU Guix. |
0afdc485 | 20 | ;;; |
233e7676 | 21 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
0afdc485 LC |
22 | ;;; under the terms of the GNU General Public License as published by |
23 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
24 | ;;; your option) any later version. | |
25 | ;;; | |
233e7676 | 26 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
0afdc485 LC |
27 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
28 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
29 | ;;; GNU General Public License for more details. | |
30 | ;;; | |
31 | ;;; You should have received a copy of the GNU General Public License | |
233e7676 | 32 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
0afdc485 LC |
33 | |
34 | (define-module (guix-package) | |
cdd5d6f9 | 35 | #:use-module (guix ui) |
0afdc485 LC |
36 | #:use-module (guix store) |
37 | #:use-module (guix derivations) | |
38 | #:use-module (guix packages) | |
39 | #:use-module (guix utils) | |
a020d2a9 | 40 | #:use-module (guix config) |
0ec1af59 | 41 | #:use-module ((guix build utils) #:select (directory-exists? mkdir-p)) |
0afdc485 LC |
42 | #:use-module (ice-9 ftw) |
43 | #:use-module (ice-9 format) | |
44 | #:use-module (ice-9 match) | |
45 | #:use-module (ice-9 regex) | |
dc5669cd | 46 | #:use-module (ice-9 vlist) |
0afdc485 LC |
47 | #:use-module (srfi srfi-1) |
48 | #:use-module (srfi srfi-11) | |
49 | #:use-module (srfi srfi-26) | |
50 | #:use-module (srfi srfi-34) | |
51 | #:use-module (srfi srfi-37) | |
59a43334 | 52 | #:use-module (gnu packages) |
1ffa7090 LC |
53 | #:use-module ((gnu packages base) #:select (guile-final)) |
54 | #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) | |
0afdc485 LC |
55 | #:export (guix-package)) |
56 | ||
0afdc485 | 57 | (define %store |
c4d64534 | 58 | (make-parameter #f)) |
0afdc485 LC |
59 | |
60 | \f | |
61 | ;;; | |
62 | ;;; User environment. | |
63 | ;;; | |
64 | ||
65 | (define %user-environment-directory | |
66 | (and=> (getenv "HOME") | |
67 | (cut string-append <> "/.guix-profile"))) | |
68 | ||
69 | (define %profile-directory | |
0ec1af59 | 70 | (string-append (or (getenv "NIX_STATE_DIR") %state-directory) "/profiles/" |
0afdc485 LC |
71 | (or (and=> (getenv "USER") |
72 | (cut string-append "per-user/" <>)) | |
73 | "default"))) | |
74 | ||
75 | (define %current-profile | |
4aa52039 LC |
76 | ;; Call it `guix-profile', not `profile', to allow Guix profiles to |
77 | ;; coexist with Nix profiles. | |
78 | (string-append %profile-directory "/guix-profile")) | |
0afdc485 LC |
79 | |
80 | (define (profile-manifest profile) | |
81 | "Return the PROFILE's manifest." | |
82 | (let ((manifest (string-append profile "/manifest"))) | |
83 | (if (file-exists? manifest) | |
84 | (call-with-input-file manifest read) | |
4dede022 | 85 | '(manifest (version 1) (packages ()))))) |
0afdc485 LC |
86 | |
87 | (define (manifest-packages manifest) | |
88 | "Return the packages listed in MANIFEST." | |
89 | (match manifest | |
4dede022 LC |
90 | (('manifest ('version 0) |
91 | ('packages ((name version output path) ...))) | |
92 | (zip name version output path | |
93 | (make-list (length name) '()))) | |
94 | ||
95 | ;; Version 1 adds a list of propagated inputs to the | |
96 | ;; name/version/output/path tuples. | |
97 | (('manifest ('version 1) | |
98 | ('packages (packages ...))) | |
0afdc485 | 99 | packages) |
4dede022 | 100 | |
0afdc485 LC |
101 | (_ |
102 | (error "unsupported manifest format" manifest)))) | |
103 | ||
24e262f0 LC |
104 | (define (profile-regexp profile) |
105 | "Return a regular expression that matches PROFILE's name and number." | |
106 | (make-regexp (string-append "^" (regexp-quote (basename profile)) | |
107 | "-([0-9]+)"))) | |
108 | ||
9241172c LC |
109 | (define (profile-numbers profile) |
110 | "Return the list of generation numbers of PROFILE, or '(0) if no | |
111 | former profiles were found." | |
0afdc485 LC |
112 | (define* (scandir name #:optional (select? (const #t)) |
113 | (entry<? (@ (ice-9 i18n) string-locale<?))) | |
114 | ;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19. | |
115 | (define (enter? dir stat result) | |
116 | (and stat (string=? dir name))) | |
117 | ||
118 | (define (visit basename result) | |
119 | (if (select? basename) | |
120 | (cons basename result) | |
121 | result)) | |
122 | ||
123 | (define (leaf name stat result) | |
124 | (and result | |
125 | (visit (basename name) result))) | |
126 | ||
127 | (define (down name stat result) | |
128 | (visit "." '())) | |
129 | ||
130 | (define (up name stat result) | |
131 | (visit ".." result)) | |
132 | ||
133 | (define (skip name stat result) | |
134 | ;; All the sub-directories are skipped. | |
135 | (visit (basename name) result)) | |
136 | ||
137 | (define (error name* stat errno result) | |
138 | (if (string=? name name*) ; top-level NAME is unreadable | |
139 | result | |
140 | (visit (basename name*) result))) | |
141 | ||
142 | (and=> (file-system-fold enter? leaf down up skip error #f name lstat) | |
143 | (lambda (files) | |
144 | (sort files entry<?)))) | |
145 | ||
146 | (match (scandir (dirname profile) | |
24e262f0 | 147 | (cute regexp-exec (profile-regexp profile) <>)) |
0afdc485 | 148 | (#f ; no profile directory |
9241172c | 149 | '(0)) |
0afdc485 | 150 | (() ; no profiles |
9241172c | 151 | '(0)) |
0afdc485 | 152 | ((profiles ...) ; former profiles around |
9241172c LC |
153 | (map (compose string->number |
154 | (cut match:substring <> 1) | |
155 | (cute regexp-exec (profile-regexp profile) <>)) | |
156 | profiles)))) | |
157 | ||
9241172c LC |
158 | (define (previous-profile-number profile number) |
159 | "Return the number of the generation before generation NUMBER of | |
160 | PROFILE, or 0 if none exists. It could be NUMBER - 1, but it's not the | |
161 | case when generations have been deleted (there are \"holes\")." | |
162 | (fold (lambda (candidate highest) | |
163 | (if (and (< candidate number) (> candidate highest)) | |
164 | candidate | |
165 | highest)) | |
166 | 0 | |
167 | (profile-numbers profile))) | |
0afdc485 LC |
168 | |
169 | (define (profile-derivation store packages) | |
170 | "Return a derivation that builds a profile (a user environment) with | |
4dede022 | 171 | all of PACKAGES, a list of name/version/output/path/deps tuples." |
0afdc485 LC |
172 | (define builder |
173 | `(begin | |
174 | (use-modules (ice-9 pretty-print) | |
175 | (guix build union)) | |
176 | ||
177 | (setvbuf (current-output-port) _IOLBF) | |
178 | (setvbuf (current-error-port) _IOLBF) | |
179 | ||
180 | (let ((output (assoc-ref %outputs "out")) | |
181 | (inputs (map cdr %build-inputs))) | |
182 | (format #t "building user environment `~a' with ~a packages...~%" | |
183 | output (length inputs)) | |
184 | (union-build output inputs) | |
185 | (call-with-output-file (string-append output "/manifest") | |
186 | (lambda (p) | |
4dede022 | 187 | (pretty-print '(manifest (version 1) |
0afdc485 LC |
188 | (packages ,packages)) |
189 | p)))))) | |
190 | ||
191 | (build-expression->derivation store "user-environment" | |
192 | (%current-system) | |
193 | builder | |
4dede022 LC |
194 | (append-map (match-lambda |
195 | ((name version output path deps) | |
196 | `((,name ,path) | |
197 | ,@deps))) | |
198 | packages) | |
0afdc485 LC |
199 | #:modules '((guix build union)))) |
200 | ||
24e262f0 LC |
201 | (define (profile-number profile) |
202 | "Return PROFILE's number or 0. An absolute file name must be used." | |
203 | (or (and=> (false-if-exception (regexp-exec (profile-regexp profile) | |
204 | (basename (readlink profile)))) | |
205 | (compose string->number (cut match:substring <> 1))) | |
206 | 0)) | |
207 | ||
82fe08ed LC |
208 | (define (switch-symlinks link target) |
209 | "Atomically switch LINK, a symbolic link, to point to TARGET. Works | |
210 | both when LINK already exists and when it does not." | |
211 | (let ((pivot (string-append link ".new"))) | |
212 | (symlink target pivot) | |
213 | (rename-file pivot link))) | |
214 | ||
24e262f0 LC |
215 | (define (roll-back profile) |
216 | "Roll back to the previous generation of PROFILE." | |
9241172c LC |
217 | (let* ((number (profile-number profile)) |
218 | (previous-number (previous-profile-number profile number)) | |
67668155 LC |
219 | (previous-profile (format #f "~a-~a-link" |
220 | profile previous-number)) | |
9241172c | 221 | (manifest (string-append previous-profile "/manifest"))) |
24e262f0 LC |
222 | |
223 | (define (switch-link) | |
224 | ;; Atomically switch PROFILE to the previous profile. | |
82fe08ed LC |
225 | (format #t (_ "switching from generation ~a to ~a~%") |
226 | number previous-number) | |
227 | (switch-symlinks profile previous-profile)) | |
24e262f0 | 228 | |
d9307267 | 229 | (cond ((not (file-exists? profile)) ; invalid profile |
9241172c | 230 | (format (current-error-port) |
d9307267 | 231 | (_ "error: profile `~a' does not exist~%") |
9241172c | 232 | profile)) |
d9307267 LC |
233 | ((zero? number) ; empty profile |
234 | (format (current-error-port) | |
235 | (_ "nothing to do: already at the empty profile~%"))) | |
236 | ((or (zero? previous-number) ; going to emptiness | |
9241172c | 237 | (not (file-exists? previous-profile))) |
d9307267 LC |
238 | (let*-values (((drv-path drv) |
239 | (profile-derivation (%store) '())) | |
240 | ((prof) | |
241 | (derivation-output-path | |
242 | (assoc-ref (derivation-outputs drv) "out")))) | |
243 | (when (not (build-derivations (%store) (list drv-path))) | |
244 | (leave (_ "failed to build the empty profile~%"))) | |
245 | ||
82fe08ed | 246 | (switch-symlinks previous-profile prof) |
d9307267 LC |
247 | (switch-link))) |
248 | (else (switch-link))))) ; anything else | |
24e262f0 | 249 | |
acc08466 NK |
250 | (define (find-packages-by-description rx) |
251 | "Search in SYNOPSIS and DESCRIPTION using RX. Return a list of | |
252 | matching packages." | |
253 | (define (same-location? p1 p2) | |
254 | ;; Compare locations of two packages. | |
255 | (equal? (package-location p1) (package-location p2))) | |
256 | ||
257 | (delete-duplicates | |
258 | (sort | |
259 | (fold-packages (lambda (package result) | |
260 | (define matches? | |
261 | (cut regexp-exec rx <>)) | |
262 | ||
263 | (if (or (and=> (package-synopsis package) | |
264 | (compose matches? gettext)) | |
265 | (and=> (package-description package) | |
266 | (compose matches? gettext))) | |
267 | (cons package result) | |
268 | result)) | |
269 | '()) | |
270 | (lambda (p1 p2) | |
271 | (string<? (package-name p1) | |
272 | (package-name p2)))) | |
273 | same-location?)) | |
274 | ||
4dede022 LC |
275 | (define (input->name+path input) |
276 | "Convert the name/package/sub-drv tuple INPUT to a name/store-path tuple." | |
277 | (let loop ((input input)) | |
278 | (match input | |
279 | ((name package) | |
280 | (loop `(,name ,package "out"))) | |
281 | ((name package sub-drv) | |
282 | (let*-values (((_ drv) | |
283 | (package-derivation (%store) package)) | |
284 | ((out) | |
285 | (derivation-output-path | |
286 | (assoc-ref (derivation-outputs drv) sub-drv)))) | |
287 | `(,name ,out)))))) | |
288 | ||
0afdc485 LC |
289 | \f |
290 | ;;; | |
291 | ;;; Command-line options. | |
292 | ;;; | |
293 | ||
294 | (define %default-options | |
295 | ;; Alist of default option values. | |
296 | `((profile . ,%current-profile))) | |
297 | ||
0afdc485 LC |
298 | (define (show-help) |
299 | (display (_ "Usage: guix-package [OPTION]... PACKAGES... | |
300 | Install, remove, or upgrade PACKAGES in a single transaction.\n")) | |
301 | (display (_ " | |
302 | -i, --install=PACKAGE install PACKAGE")) | |
303 | (display (_ " | |
304 | -r, --remove=PACKAGE remove PACKAGE")) | |
305 | (display (_ " | |
306 | -u, --upgrade=REGEXP upgrade all the installed packages matching REGEXP")) | |
24e262f0 LC |
307 | (display (_ " |
308 | --roll-back roll back to the previous generation")) | |
0afdc485 LC |
309 | (newline) |
310 | (display (_ " | |
311 | -p, --profile=PROFILE use PROFILE instead of the user's default profile")) | |
312 | (display (_ " | |
313 | -n, --dry-run show what would be done without actually doing it")) | |
314 | (display (_ " | |
cc57f25d | 315 | --bootstrap use the bootstrap Guile to build the profile")) |
70915c1a LC |
316 | (display (_ " |
317 | --verbose produce verbose output")) | |
0afdc485 LC |
318 | (newline) |
319 | (display (_ " | |
acc08466 NK |
320 | -s, --search=REGEXP search in synopsis and description using REGEXP")) |
321 | (display (_ " | |
733b4130 LC |
322 | -I, --list-installed[=REGEXP] |
323 | list installed packages matching REGEXP")) | |
64fc89b6 LC |
324 | (display (_ " |
325 | -A, --list-available[=REGEXP] | |
326 | list available packages matching REGEXP")) | |
733b4130 LC |
327 | (newline) |
328 | (display (_ " | |
0afdc485 LC |
329 | -h, --help display this help and exit")) |
330 | (display (_ " | |
331 | -V, --version display version information and exit")) | |
332 | (newline) | |
3441e164 | 333 | (show-bug-report-information)) |
0afdc485 LC |
334 | |
335 | (define %options | |
336 | ;; Specification of the command-line options. | |
337 | (list (option '(#\h "help") #f #f | |
338 | (lambda args | |
339 | (show-help) | |
340 | (exit 0))) | |
341 | (option '(#\V "version") #f #f | |
342 | (lambda args | |
cdd5d6f9 | 343 | (show-version-and-exit "guix-package"))) |
0afdc485 LC |
344 | |
345 | (option '(#\i "install") #t #f | |
346 | (lambda (opt name arg result) | |
347 | (alist-cons 'install arg result))) | |
348 | (option '(#\r "remove") #t #f | |
349 | (lambda (opt name arg result) | |
350 | (alist-cons 'remove arg result))) | |
dc5669cd MW |
351 | (option '(#\u "upgrade") #t #f |
352 | (lambda (opt name arg result) | |
353 | (alist-cons 'upgrade arg result))) | |
24e262f0 LC |
354 | (option '("roll-back") #f #f |
355 | (lambda (opt name arg result) | |
356 | (alist-cons 'roll-back? #t result))) | |
0afdc485 LC |
357 | (option '(#\p "profile") #t #f |
358 | (lambda (opt name arg result) | |
359 | (alist-cons 'profile arg | |
360 | (alist-delete 'profile result)))) | |
361 | (option '(#\n "dry-run") #f #f | |
362 | (lambda (opt name arg result) | |
363 | (alist-cons 'dry-run? #t result))) | |
cc57f25d | 364 | (option '("bootstrap") #f #f |
0afdc485 | 365 | (lambda (opt name arg result) |
733b4130 | 366 | (alist-cons 'bootstrap? #t result))) |
70915c1a LC |
367 | (option '("verbose") #f #f |
368 | (lambda (opt name arg result) | |
369 | (alist-cons 'verbose? #t result))) | |
acc08466 NK |
370 | (option '(#\s "search") #t #f |
371 | (lambda (opt name arg result) | |
372 | (cons `(query search ,(or arg "")) | |
373 | result))) | |
733b4130 LC |
374 | (option '(#\I "list-installed") #f #t |
375 | (lambda (opt name arg result) | |
376 | (cons `(query list-installed ,(or arg "")) | |
64fc89b6 LC |
377 | result))) |
378 | (option '(#\A "list-available") #f #t | |
379 | (lambda (opt name arg result) | |
380 | (cons `(query list-available ,(or arg "")) | |
733b4130 | 381 | result))))) |
0afdc485 LC |
382 | |
383 | \f | |
384 | ;;; | |
385 | ;;; Entry point. | |
386 | ;;; | |
387 | ||
388 | (define (guix-package . args) | |
389 | (define (parse-options) | |
390 | ;; Return the alist of option values. | |
391 | (args-fold args %options | |
392 | (lambda (opt name arg result) | |
393 | (leave (_ "~A: unrecognized option~%") name)) | |
394 | (lambda (arg result) | |
3b9c0020 | 395 | (leave (_ "~A: extraneous argument~%") arg)) |
0afdc485 LC |
396 | %default-options)) |
397 | ||
9762706b LC |
398 | (define (guile-missing?) |
399 | ;; Return #t if %GUILE-FOR-BUILD is not available yet. | |
400 | (let ((out (derivation-path->output-path (%guile-for-build)))) | |
c4d64534 | 401 | (not (valid-path? (%store) out)))) |
9762706b | 402 | |
0afdc485 LC |
403 | (define (show-what-to-build drv dry-run?) |
404 | ;; Show what will/would be built in realizing the derivations listed | |
405 | ;; in DRV. | |
406 | (let* ((req (append-map (lambda (drv-path) | |
407 | (let ((d (call-with-input-file drv-path | |
408 | read-derivation))) | |
c4d64534 LC |
409 | (derivation-prerequisites-to-build |
410 | (%store) d))) | |
0afdc485 LC |
411 | drv)) |
412 | (req* (delete-duplicates | |
c4d64534 | 413 | (append (remove (compose (cute valid-path? (%store) <>) |
0afdc485 LC |
414 | derivation-path->output-path) |
415 | drv) | |
416 | (map derivation-input-path req))))) | |
417 | (if dry-run? | |
418 | (format (current-error-port) | |
419 | (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]" | |
420 | "~:[the following derivations would be built:~%~{ ~a~%~}~;~]" | |
421 | (length req*)) | |
422 | (null? req*) req*) | |
423 | (format (current-error-port) | |
424 | (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]" | |
425 | "~:[the following derivations will be built:~%~{ ~a~%~}~;~]" | |
426 | (length req*)) | |
427 | (null? req*) req*)))) | |
428 | ||
dc5669cd MW |
429 | (define newest-available-packages |
430 | (memoize find-newest-available-packages)) | |
431 | ||
432 | (define (find-best-packages-by-name name version) | |
433 | (if version | |
434 | (find-packages-by-name name version) | |
435 | (match (vhash-assoc name (newest-available-packages)) | |
436 | ((_ version pkgs ...) pkgs) | |
437 | (#f '())))) | |
438 | ||
0afdc485 LC |
439 | (define (find-package name) |
440 | ;; Find the package NAME; NAME may contain a version number and a | |
dc5669cd MW |
441 | ;; sub-derivation name. If the version number is not present, |
442 | ;; return the preferred newest version. | |
0afdc485 | 443 | (define request name) |
0afdc485 | 444 | |
aa92cf98 LC |
445 | (define (ensure-output p sub-drv) |
446 | (if (member sub-drv (package-outputs p)) | |
447 | p | |
448 | (leave (_ "~a: error: package `~a' lacks output `~a'~%") | |
449 | (location->string (package-location p)) | |
450 | (package-full-name p) | |
451 | sub-drv))) | |
452 | ||
0afdc485 LC |
453 | (let*-values (((name sub-drv) |
454 | (match (string-rindex name #\:) | |
455 | (#f (values name "out")) | |
9518856b LC |
456 | (colon (values (substring name 0 colon) |
457 | (substring name (+ 1 colon)))))) | |
0afdc485 | 458 | ((name version) |
9b48fb88 | 459 | (package-name->name+version name))) |
dc5669cd | 460 | (match (find-best-packages-by-name name version) |
0afdc485 | 461 | ((p) |
4dede022 LC |
462 | (list name (package-version p) sub-drv (ensure-output p sub-drv) |
463 | (package-transitive-propagated-inputs p))) | |
c6f09dfa | 464 | ((p p* ...) |
0afdc485 LC |
465 | (format (current-error-port) |
466 | (_ "warning: ambiguous package specification `~a'~%") | |
467 | request) | |
468 | (format (current-error-port) | |
d9d05363 LC |
469 | (_ "warning: choosing ~a from ~a~%") |
470 | (package-full-name p) | |
471 | (location->string (package-location p))) | |
4dede022 LC |
472 | (list name (package-version p) sub-drv (ensure-output p sub-drv) |
473 | (package-transitive-propagated-inputs p))) | |
0afdc485 LC |
474 | (() |
475 | (leave (_ "~a: package not found~%") request))))) | |
476 | ||
dc5669cd MW |
477 | (define (upgradeable? name current-version current-path) |
478 | ;; Return #t if there's a version of package NAME newer than | |
479 | ;; CURRENT-VERSION, or if the newest available version is equal to | |
480 | ;; CURRENT-VERSION but would have an output path different than | |
481 | ;; CURRENT-PATH. | |
482 | (match (vhash-assoc name (newest-available-packages)) | |
483 | ((_ candidate-version pkg . rest) | |
484 | (case (version-compare candidate-version current-version) | |
485 | ((>) #t) | |
486 | ((<) #f) | |
487 | ((=) (let ((candidate-path (derivation-path->output-path | |
488 | (package-derivation (%store) pkg)))) | |
489 | (not (string=? current-path candidate-path)))))) | |
490 | (#f #f))) | |
491 | ||
0ec1af59 LC |
492 | (define (ensure-default-profile) |
493 | ;; Ensure the default profile symlink and directory exist. | |
494 | ||
495 | ;; Create ~/.guix-profile if it doesn't exist yet. | |
496 | (when (and %user-environment-directory | |
497 | %current-profile | |
498 | (not (false-if-exception | |
499 | (lstat %user-environment-directory)))) | |
500 | (symlink %current-profile %user-environment-directory)) | |
501 | ||
502 | ;; Attempt to create /…/profiles/per-user/$USER if needed. | |
503 | (unless (directory-exists? %profile-directory) | |
504 | (catch 'system-error | |
505 | (lambda () | |
506 | (mkdir-p %profile-directory)) | |
507 | (lambda args | |
508 | ;; Often, we cannot create %PROFILE-DIRECTORY because its | |
509 | ;; parent directory is root-owned and we're running | |
510 | ;; unprivileged. | |
511 | (format (current-error-port) | |
512 | (_ "error: while creating directory `~a': ~a~%") | |
513 | %profile-directory | |
514 | (strerror (system-error-errno args))) | |
515 | (format (current-error-port) | |
516 | (_ "Please create the `~a' directory, with you as the owner.~%") | |
517 | %profile-directory) | |
518 | (exit 1))))) | |
519 | ||
733b4130 LC |
520 | (define (process-actions opts) |
521 | ;; Process any install/remove/upgrade action from OPTS. | |
24e262f0 LC |
522 | |
523 | (define dry-run? (assoc-ref opts 'dry-run?)) | |
524 | (define verbose? (assoc-ref opts 'verbose?)) | |
525 | (define profile (assoc-ref opts 'profile)) | |
526 | ||
4dede022 LC |
527 | (define (canonicalize-deps deps) |
528 | ;; Remove duplicate entries from DEPS, a list of propagated inputs, | |
529 | ;; where each input is a name/path tuple. | |
530 | (define (same? d1 d2) | |
531 | (match d1 | |
532 | ((_ path1) | |
533 | (match d2 | |
534 | ((_ path2) | |
535 | (string=? path1 path2)))))) | |
536 | ||
537 | (delete-duplicates (map input->name+path deps) same?)) | |
538 | ||
24e262f0 LC |
539 | ;; First roll back if asked to. |
540 | (if (and (assoc-ref opts 'roll-back?) (not dry-run?)) | |
541 | (begin | |
542 | (roll-back profile) | |
543 | (process-actions (alist-delete 'roll-back? opts))) | |
dc5669cd MW |
544 | (let* ((installed (manifest-packages (profile-manifest profile))) |
545 | (upgrade-regexps (filter-map (match-lambda | |
546 | (('upgrade . regexp) | |
547 | (make-regexp regexp)) | |
548 | (_ #f)) | |
549 | opts)) | |
550 | (upgrade (if (null? upgrade-regexps) | |
551 | '() | |
552 | (let ((newest (find-newest-available-packages))) | |
553 | (filter-map (match-lambda | |
554 | ((name version output path _) | |
555 | (and (any (cut regexp-exec <> name) | |
556 | upgrade-regexps) | |
557 | (upgradeable? name version path) | |
558 | (find-package name))) | |
559 | (_ #f)) | |
560 | installed)))) | |
561 | (install (append | |
562 | upgrade | |
563 | (filter-map (match-lambda | |
564 | (('install . (? store-path?)) | |
565 | #f) | |
566 | (('install . package) | |
567 | (find-package package)) | |
568 | (_ #f)) | |
569 | opts))) | |
24e262f0 LC |
570 | (drv (filter-map (match-lambda |
571 | ((name version sub-drv | |
4dede022 LC |
572 | (? package? package) |
573 | (deps ...)) | |
24e262f0 LC |
574 | (package-derivation (%store) package)) |
575 | (_ #f)) | |
576 | install)) | |
577 | (install* (append | |
578 | (filter-map (match-lambda | |
579 | (('install . (? store-path? path)) | |
580 | (let-values (((name version) | |
581 | (package-name->name+version | |
582 | (store-path-package-name | |
583 | path)))) | |
4dede022 | 584 | `(,name ,version #f ,path ()))) |
24e262f0 LC |
585 | (_ #f)) |
586 | opts) | |
587 | (map (lambda (tuple drv) | |
588 | (match tuple | |
4dede022 | 589 | ((name version sub-drv _ (deps ...)) |
24e262f0 LC |
590 | (let ((output-path |
591 | (derivation-path->output-path | |
592 | drv sub-drv))) | |
4dede022 LC |
593 | `(,name ,version ,sub-drv ,output-path |
594 | ,(canonicalize-deps deps)))))) | |
24e262f0 LC |
595 | install drv))) |
596 | (remove (filter-map (match-lambda | |
597 | (('remove . package) | |
598 | package) | |
599 | (_ #f)) | |
600 | opts)) | |
601 | (packages (append install* | |
602 | (fold (lambda (package result) | |
603 | (match package | |
604 | ((name _ ...) | |
605 | (alist-delete name result)))) | |
dc5669cd | 606 | (fold alist-delete installed remove) |
24e262f0 LC |
607 | install*)))) |
608 | ||
609 | (when (equal? profile %current-profile) | |
610 | (ensure-default-profile)) | |
611 | ||
612 | (show-what-to-build drv dry-run?) | |
613 | ||
614 | (or dry-run? | |
615 | (and (build-derivations (%store) drv) | |
616 | (let* ((prof-drv (profile-derivation (%store) packages)) | |
617 | (prof (derivation-path->output-path prof-drv)) | |
618 | (old-drv (profile-derivation | |
619 | (%store) (manifest-packages | |
620 | (profile-manifest profile)))) | |
621 | (old-prof (derivation-path->output-path old-drv)) | |
82fe08ed LC |
622 | (number (profile-number profile)) |
623 | ||
624 | ;; Always use NUMBER + 1 for the new profile, | |
625 | ;; possibly overwriting a "previous future | |
626 | ;; generation". | |
627 | (name (format #f "~a-~a-link" | |
628 | profile (+ 1 number)))) | |
24e262f0 LC |
629 | (if (string=? old-prof prof) |
630 | (when (or (pair? install) (pair? remove)) | |
631 | (format (current-error-port) | |
632 | (_ "nothing to be done~%"))) | |
633 | (and (parameterize ((current-build-output-port | |
634 | ;; Output something when Guile | |
635 | ;; needs to be built. | |
636 | (if (or verbose? (guile-missing?)) | |
637 | (current-error-port) | |
638 | (%make-void-port "w")))) | |
639 | (build-derivations (%store) (list prof-drv))) | |
640 | (begin | |
82fe08ed LC |
641 | (switch-symlinks name prof) |
642 | (switch-symlinks profile name)))))))))) | |
733b4130 LC |
643 | |
644 | (define (process-query opts) | |
645 | ;; Process any query specified by OPTS. Return #t when a query was | |
646 | ;; actually processed, #f otherwise. | |
647 | (let ((profile (assoc-ref opts 'profile))) | |
648 | (match (assoc-ref opts 'query) | |
649 | (('list-installed regexp) | |
650 | (let* ((regexp (and regexp (make-regexp regexp))) | |
651 | (manifest (profile-manifest profile)) | |
652 | (installed (manifest-packages manifest))) | |
653 | (for-each (match-lambda | |
4dede022 | 654 | ((name version output path _) |
733b4130 LC |
655 | (when (or (not regexp) |
656 | (regexp-exec regexp name)) | |
657 | (format #t "~a\t~a\t~a\t~a~%" | |
658 | name (or version "?") output path)))) | |
64fc89b6 LC |
659 | installed) |
660 | #t)) | |
acc08466 | 661 | |
64fc89b6 LC |
662 | (('list-available regexp) |
663 | (let* ((regexp (and regexp (make-regexp regexp))) | |
664 | (available (fold-packages | |
665 | (lambda (p r) | |
666 | (let ((n (package-name p))) | |
667 | (if regexp | |
668 | (if (regexp-exec regexp n) | |
669 | (cons p r) | |
670 | r) | |
671 | (cons p r)))) | |
672 | '()))) | |
673 | (for-each (lambda (p) | |
44b6be77 | 674 | (format #t "~a\t~a\t~a\t~a~%" |
64fc89b6 LC |
675 | (package-name p) |
676 | (package-version p) | |
44b6be77 | 677 | (string-join (package-outputs p) ",") |
64fc89b6 LC |
678 | (location->string (package-location p)))) |
679 | (sort available | |
680 | (lambda (p1 p2) | |
681 | (string<? (package-name p1) | |
682 | (package-name p2))))) | |
683 | #t)) | |
acc08466 NK |
684 | |
685 | (('search regexp) | |
cb09fb24 | 686 | (let ((regexp (make-regexp regexp regexp/icase))) |
299112d3 | 687 | (for-each (cute package->recutils <> (current-output-port)) |
acc08466 NK |
688 | (find-packages-by-description regexp)) |
689 | #t)) | |
733b4130 LC |
690 | (_ #f)))) |
691 | ||
473b03b3 | 692 | (install-locale) |
0afdc485 LC |
693 | (textdomain "guix") |
694 | (setvbuf (current-output-port) _IOLBF) | |
695 | (setvbuf (current-error-port) _IOLBF) | |
696 | ||
697 | (let ((opts (parse-options))) | |
0f5378eb LC |
698 | (or (process-query opts) |
699 | (parameterize ((%store (open-connection))) | |
700 | (with-error-handling | |
c4d64534 LC |
701 | (parameterize ((%guile-for-build |
702 | (package-derivation (%store) | |
703 | (if (assoc-ref opts 'bootstrap?) | |
704 | %bootstrap-guile | |
705 | guile-final)))) | |
706 | (process-actions opts))))))) |