| blob | b545ea2672c634b62f579efb70cbe9f847c26dc2 |
1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
4 ;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org>
5 ;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
6 ;;;
7 ;;; This file is part of GNU Guix.
8 ;;;
9 ;;; GNU Guix is free software; you can redistribute it and/or modify it
10 ;;; under the terms of the GNU General Public License as published by
11 ;;; the Free Software Foundation; either version 3 of the License, or (at
12 ;;; your option) any later version.
13 ;;;
14 ;;; GNU Guix is distributed in the hope that it will be useful, but
15 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;;; GNU General Public License for more details.
18 ;;;
19 ;;; You should have received a copy of the GNU General Public License
20 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
22 (define-module (guix scripts package)
23 #:use-module (guix ui)
24 #:use-module (guix store)
25 #:use-module (guix derivations)
26 #:use-module (guix packages)
27 #:use-module (guix profiles)
28 #:use-module (guix search-paths)
29 #:use-module (guix monads)
30 #:use-module (guix utils)
31 #:use-module (guix config)
32 #:use-module (guix scripts build)
33 #:use-module ((guix build utils)
34 #:select (directory-exists? mkdir-p search-path-as-list))
35 #:use-module (ice-9 format)
36 #:use-module (ice-9 match)
37 #:use-module (ice-9 regex)
38 #:use-module (ice-9 vlist)
39 #:use-module (srfi srfi-1)
40 #:use-module (srfi srfi-11)
41 #:use-module (srfi srfi-19)
42 #:use-module (srfi srfi-26)
43 #:use-module (srfi srfi-34)
44 #:use-module (srfi srfi-35)
45 #:use-module (srfi srfi-37)
46 #:use-module (gnu packages)
47 #:use-module (gnu packages base)
48 #:use-module (gnu packages guile)
49 #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
50 #:export (switch-to-generation
51 switch-to-previous-generation
52 roll-back
53 delete-generation
54 delete-generations
55 display-search-paths
56 guix-package))
58 (define %store
59 (make-parameter #f))
61 \f
62 ;;;
63 ;;; Profiles.
64 ;;;
66 (define %user-profile-directory
67 (and=> (getenv "HOME")
68 (cut string-append <> "/.guix-profile")))
70 (define %profile-directory
71 (string-append %state-directory "/profiles/"
72 (or (and=> (or (getenv "USER")
73 (getenv "LOGNAME"))
74 (cut string-append "per-user/" <>))
75 "default")))
77 (define %current-profile
78 ;; Call it `guix-profile', not `profile', to allow Guix profiles to
79 ;; coexist with Nix profiles.
80 (string-append %profile-directory "/guix-profile"))
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))
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))
102 (define (link-to-empty-profile store generation)
103 "Link GENERATION, a string, to the empty profile."
104 (let* ((drv (run-with-store store
105 (profile-derivation (manifest '()))))
106 (prof (derivation->output-path drv "out")))
107 (when (not (build-derivations store (list drv)))
108 (leave (_ "failed to build the empty profile~%")))
110 (switch-symlinks generation prof)))
112 (define (switch-to-generation profile number)
113 "Atomically switch PROFILE to the generation NUMBER."
114 (let ((current (generation-number profile))
115 (generation (generation-file-name profile number)))
116 (cond ((not (file-exists? profile))
117 (raise (condition (&profile-not-found-error
118 (profile profile)))))
119 ((not (file-exists? generation))
120 (raise (condition (&missing-generation-error
121 (profile profile)
122 (generation number)))))
123 (else
124 (format #t (_ "switching from generation ~a to ~a~%")
125 current number)
126 (switch-symlinks profile generation)))))
128 (define (switch-to-previous-generation profile)
129 "Atomically switch PROFILE to the previous generation."
130 (switch-to-generation profile
131 (previous-generation-number profile)))
133 (define (roll-back store profile)
134 "Roll back to the previous generation of PROFILE."
135 (let* ((number (generation-number profile))
136 (previous-number (previous-generation-number profile number))
137 (previous-generation (generation-file-name profile previous-number)))
138 (cond ((not (file-exists? profile)) ; invalid profile
139 (raise (condition (&profile-not-found-error
140 (profile profile)))))
141 ((zero? number) ; empty profile
142 (format (current-error-port)
143 (_ "nothing to do: already at the empty profile~%")))
144 ((or (zero? previous-number) ; going to emptiness
145 (not (file-exists? previous-generation)))
146 (link-to-empty-profile store previous-generation)
147 (switch-to-previous-generation profile))
148 (else
149 (switch-to-previous-generation profile))))) ; anything else
151 (define (delete-generation store profile number)
152 "Delete generation with NUMBER from PROFILE."
153 (define (display-and-delete)
154 (let ((generation (generation-file-name profile number)))
155 (format #t (_ "deleting ~a~%") generation)
156 (delete-file generation)))
158 (let* ((current-number (generation-number profile))
159 (previous-number (previous-generation-number profile number))
160 (previous-generation (generation-file-name profile previous-number)))
161 (cond ((zero? number)) ; do not delete generation 0
162 ((and (= number current-number)
163 (not (file-exists? previous-generation)))
164 (link-to-empty-profile store previous-generation)
165 (switch-to-previous-generation profile)
166 (display-and-delete))
167 ((= number current-number)
168 (roll-back store profile)
169 (display-and-delete))
170 (else
171 (display-and-delete)))))
173 (define (delete-generations store profile generations)
174 "Delete GENERATIONS from PROFILE.
175 GENERATIONS is a list of generation numbers."
176 (for-each (cut delete-generation store profile <>)
177 generations))
179 (define* (matching-generations str #:optional (profile %current-profile)
180 #:key (duration-relation <=))
181 "Return the list of available generations matching a pattern in STR. See
182 'string->generations' and 'string->duration' for the list of valid patterns.
183 When STR is a duration pattern, return all the generations whose ctime has
184 DURATION-RELATION with the current time."
185 (define (valid-generations lst)
186 (define (valid-generation? n)
187 (any (cut = n <>) (generation-numbers profile)))
189 (fold-right (lambda (x acc)
190 (if (valid-generation? x)
191 (cons x acc)
192 acc))
193 '()
194 lst))
196 (define (filter-generations generations)
197 (match generations
198 (() '())
199 (('>= n)
200 (drop-while (cut > n <>)
201 (generation-numbers profile)))
202 (('<= n)
203 (valid-generations (iota n 1)))
204 ((lst ..1)
205 (valid-generations lst))
206 (_ #f)))
208 (define (filter-by-duration duration)
209 (define (time-at-midnight time)
210 ;; Return TIME at midnight by setting nanoseconds, seconds, minutes, and
211 ;; hours to zeros.
212 (let ((d (time-utc->date time)))
213 (date->time-utc
214 (make-date 0 0 0 0
215 (date-day d) (date-month d)
216 (date-year d) (date-zone-offset d)))))
218 (define generation-ctime-alist
219 (map (lambda (number)
220 (cons number
221 (time-second
222 (time-at-midnight
223 (generation-time profile number)))))
224 (generation-numbers profile)))
226 (match duration
227 (#f #f)
228 (res
229 (let ((s (time-second
230 (subtract-duration (time-at-midnight (current-time))
231 duration))))
232 (delete #f (map (lambda (x)
233 (and (duration-relation s (cdr x))
234 (first x)))
235 generation-ctime-alist))))))
237 (cond ((string->generations str)
238 =>
239 filter-generations)
240 ((string->duration str)
241 =>
242 filter-by-duration)
243 (else #f)))
245 (define (delete-matching-generations store profile pattern)
246 "Delete from PROFILE all the generations matching PATTERN. PATTERN must be
247 a string denoting a set of generations: the empty list means \"all generations
248 but the current one\", a number designates a generation, and other patterns
249 denote ranges as interpreted by 'matching-derivations'."
250 (let ((current (generation-number profile)))
251 (cond ((not (file-exists? profile)) ; XXX: race condition
252 (raise (condition (&profile-not-found-error
253 (profile profile)))))
254 ((string-null? pattern)
255 (delete-generations (%store) profile
256 (delv current (profile-generations profile))))
257 ;; Do not delete the zeroth generation.
258 ((equal? 0 (string->number pattern))
259 #t)
261 ;; If PATTERN is a duration, match generations that are
262 ;; older than the specified duration.
263 ((matching-generations pattern profile
264 #:duration-relation >)
265 =>
266 (lambda (numbers)
267 (when (memv current numbers)
268 (warning (_ "not removing generation ~a, which is current~%")
269 current))
271 ;; Make sure we don't inadvertently remove the current
272 ;; generation.
273 (let ((numbers (delv current numbers)))
274 (when (null-list? numbers)
275 (leave (_ "no matching generation~%")))
276 (delete-generations (%store) profile numbers))))
277 (else
278 (leave (_ "invalid syntax: ~a~%") pattern)))))
280 \f
281 ;;;
282 ;;; Package specifications.
283 ;;;
285 (define (find-packages-by-description rx)
286 "Return the list of packages whose name, synopsis, or description matches
287 RX."
288 (define version<? (negate version>=?))
290 (sort
291 (fold-packages (lambda (package result)
292 (define matches?
293 (cut regexp-exec rx <>))
295 (if (or (matches? (package-name package))
296 (and=> (package-synopsis package)
297 (compose matches? P_))
298 (and=> (package-description package)
299 (compose matches? P_)))
300 (cons package result)
301 result))
302 '())
303 (lambda (p1 p2)
304 (case (string-compare (package-name p1) (package-name p2)
305 (const '<) (const '=) (const '>))
306 ((=) (version<? (package-version p1) (package-version p2)))
307 ((<) #t)
308 (else #f)))))
310 (define (upgradeable? name current-version current-path)
311 "Return #t if there's a version of package NAME newer than CURRENT-VERSION,
312 or if the newest available version is equal to CURRENT-VERSION but would have
313 an output path different than CURRENT-PATH."
314 (match (vhash-assoc name (find-newest-available-packages))
315 ((_ candidate-version pkg . rest)
316 (case (version-compare candidate-version current-version)
317 ((>) #t)
318 ((<) #f)
319 ((=) (let ((candidate-path (derivation->output-path
320 (package-derivation (%store) pkg))))
321 (not (string=? current-path candidate-path))))))
322 (#f #f)))
324 \f
325 ;;;
326 ;;; Search paths.
327 ;;;
329 (define* (search-path-environment-variables entries profile
330 #:optional (getenv getenv)
331 #:key (kind 'exact))
332 "Return environment variable definitions that may be needed for the use of
333 ENTRIES, a list of manifest entries, in PROFILE. Use GETENV to determine the
334 current settings and report only settings not already effective. KIND
335 must be one of 'exact, 'prefix, or 'suffix, depending on the kind of search
336 path definition to be returned."
337 (let ((search-paths (delete-duplicates
338 (cons $PATH
339 (append-map manifest-entry-search-paths
340 entries)))))
341 (filter-map (match-lambda
342 ((spec . value)
343 (let ((variable (search-path-specification-variable spec))
344 (sep (search-path-specification-separator spec)))
345 (environment-variable-definition variable value
346 #:separator sep
347 #:kind kind))))
348 (evaluate-search-paths search-paths (list profile)
349 getenv))))
351 (define* (display-search-paths entries profile
352 #:key (kind 'exact))
353 "Display the search path environment variables that may need to be set for
354 ENTRIES, a list of manifest entries, in the context of PROFILE."
355 (let* ((profile (user-friendly-profile profile))
356 (settings (search-path-environment-variables entries profile
357 #:kind kind)))
358 (unless (null? settings)
359 (format #t (_ "The following environment variable definitions may be needed:~%"))
360 (format #t "~{ ~a~%~}" settings))))
362 \f
363 ;;;
364 ;;; Command-line options.
365 ;;;
367 (define %default-options
368 ;; Alist of default option values.
369 `((profile . ,%current-profile)
370 (max-silent-time . 3600)
371 (verbosity . 0)
372 (substitutes? . #t)))
374 (define (show-help)
375 (display (_ "Usage: guix package [OPTION]...
376 Install, remove, or upgrade packages in a single transaction.\n"))
377 (display (_ "
378 -i, --install PACKAGE ...
379 install PACKAGEs"))
380 (display (_ "
381 -e, --install-from-expression=EXP
382 install the package EXP evaluates to"))
383 (display (_ "
384 -r, --remove PACKAGE ...
385 remove PACKAGEs"))
386 (display (_ "
387 -u, --upgrade[=REGEXP] upgrade all the installed packages matching REGEXP"))
388 (display (_ "
389 -m, --manifest=FILE create a new profile generation with the manifest
390 from FILE"))
391 (display (_ "
392 --do-not-upgrade[=REGEXP] do not upgrade any packages matching REGEXP"))
393 (display (_ "
394 --roll-back roll back to the previous generation"))
395 (display (_ "
396 --search-paths[=KIND]
397 display needed environment variable definitions"))
398 (display (_ "
399 -l, --list-generations[=PATTERN]
400 list generations matching PATTERN"))
401 (display (_ "
402 -d, --delete-generations[=PATTERN]
403 delete generations matching PATTERN"))
404 (display (_ "
405 -S, --switch-generation=PATTERN
406 switch to a generation matching PATTERN"))
407 (display (_ "
408 -p, --profile=PROFILE use PROFILE instead of the user's default profile"))
409 (newline)
410 (display (_ "
411 --bootstrap use the bootstrap Guile to build the profile"))
412 (display (_ "
413 --verbose produce verbose output"))
414 (newline)
415 (display (_ "
416 -s, --search=REGEXP search in synopsis and description using REGEXP"))
417 (display (_ "
418 -I, --list-installed[=REGEXP]
419 list installed packages matching REGEXP"))
420 (display (_ "
421 -A, --list-available[=REGEXP]
422 list available packages matching REGEXP"))
423 (display (_ "
424 --show=PACKAGE show details about PACKAGE"))
425 (newline)
426 (show-build-options-help)
427 (newline)
428 (display (_ "
429 -h, --help display this help and exit"))
430 (display (_ "
431 -V, --version display version information and exit"))
432 (newline)
433 (show-bug-report-information))
435 (define %options
436 ;; Specification of the command-line options.
437 (cons* (option '(#\h "help") #f #f
438 (lambda args
439 (show-help)
440 (exit 0)))
441 (option '(#\V "version") #f #f
442 (lambda args
443 (show-version-and-exit "guix package")))
445 (option '(#\i "install") #f #t
446 (lambda (opt name arg result arg-handler)
447 (let arg-handler ((arg arg) (result result))
448 (values (if arg
449 (alist-cons 'install arg result)
450 result)
451 arg-handler))))
452 (option '(#\e "install-from-expression") #t #f
453 (lambda (opt name arg result arg-handler)
454 (values (alist-cons 'install (read/eval-package-expression arg)
455 result)
456 #f)))
457 (option '(#\r "remove") #f #t
458 (lambda (opt name arg result arg-handler)
459 (let arg-handler ((arg arg) (result result))
460 (values (if arg
461 (alist-cons 'remove arg result)
462 result)
463 arg-handler))))
464 (option '(#\u "upgrade") #f #t
465 (lambda (opt name arg result arg-handler)
466 (let arg-handler ((arg arg) (result result))
467 (values (alist-cons 'upgrade arg
468 ;; Delete any prior "upgrade all"
469 ;; command, or else "--upgrade gcc"
470 ;; would upgrade everything.
471 (delete '(upgrade . #f) result))
472 arg-handler))))
473 (option '("do-not-upgrade") #f #t
474 (lambda (opt name arg result arg-handler)
475 (let arg-handler ((arg arg) (result result))
476 (values (if arg
477 (alist-cons 'do-not-upgrade arg result)
478 result)
479 arg-handler))))
480 (option '("roll-back") #f #f
481 (lambda (opt name arg result arg-handler)
482 (values (alist-cons 'roll-back? #t result)
483 #f)))
484 (option '(#\m "manifest") #t #f
485 (lambda (opt name arg result arg-handler)
486 (values (alist-cons 'manifest arg result)
487 arg-handler)))
488 (option '(#\l "list-generations") #f #t
489 (lambda (opt name arg result arg-handler)
490 (values (cons `(query list-generations ,(or arg ""))
491 result)
492 #f)))
493 (option '(#\d "delete-generations") #f #t
494 (lambda (opt name arg result arg-handler)
495 (values (alist-cons 'delete-generations (or arg "")
496 result)
497 #f)))
498 (option '(#\S "switch-generation") #t #f
499 (lambda (opt name arg result arg-handler)
500 (values (alist-cons 'switch-generation arg result)
501 #f)))
502 (option '("search-paths") #f #t
503 (lambda (opt name arg result arg-handler)
504 (let ((kind (match arg
505 ((or "exact" "prefix" "suffix")
506 (string->symbol arg))
507 (#f
508 'exact)
509 (x
510 (leave (_ "~a: unsupported \
511 kind of search path~%")
512 x)))))
513 (values (cons `(query search-paths ,kind)
514 result)
515 #f))))
516 (option '(#\p "profile") #t #f
517 (lambda (opt name arg result arg-handler)
518 (values (alist-cons 'profile (canonicalize-profile arg)
519 (alist-delete 'profile result))
520 #f)))
521 (option '(#\n "dry-run") #f #f
522 (lambda (opt name arg result arg-handler)
523 (values (alist-cons 'dry-run? #t result)
524 #f)))
525 (option '("bootstrap") #f #f
526 (lambda (opt name arg result arg-handler)
527 (values (alist-cons 'bootstrap? #t result)
528 #f)))
529 (option '("verbose") #f #f
530 (lambda (opt name arg result arg-handler)
531 (values (alist-cons 'verbose? #t result)
532 #f)))
533 (option '(#\s "search") #t #f
534 (lambda (opt name arg result arg-handler)
535 (values (cons `(query search ,(or arg ""))
536 result)
537 #f)))
538 (option '(#\I "list-installed") #f #t
539 (lambda (opt name arg result arg-handler)
540 (values (cons `(query list-installed ,(or arg ""))
541 result)
542 #f)))
543 (option '(#\A "list-available") #f #t
544 (lambda (opt name arg result arg-handler)
545 (values (cons `(query list-available ,(or arg ""))
546 result)
547 #f)))
548 (option '("show") #t #t
549 (lambda (opt name arg result arg-handler)
550 (values (cons `(query show ,arg)
551 result)
552 #f)))
554 %standard-build-options))
556 (define (options->installable opts manifest)
557 "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold',
558 return the new list of manifest entries."
559 (define (package->manifest-entry* package output)
560 (check-package-freshness package)
561 ;; When given a package via `-e', install the first of its
562 ;; outputs (XXX).
563 (package->manifest-entry package output))
565 (define upgrade-regexps
566 (filter-map (match-lambda
567 (('upgrade . regexp)
568 (make-regexp (or regexp "")))
569 (_ #f))
570 opts))
572 (define do-not-upgrade-regexps
573 (filter-map (match-lambda
574 (('do-not-upgrade . regexp)
575 (make-regexp regexp))
576 (_ #f))
577 opts))
579 (define packages-to-upgrade
580 (match upgrade-regexps
581 (()
582 '())
583 ((_ ...)
584 (filter-map (match-lambda
585 (($ <manifest-entry> name version output path _)
586 (and (any (cut regexp-exec <> name)
587 upgrade-regexps)
588 (not (any (cut regexp-exec <> name)
589 do-not-upgrade-regexps))
590 (upgradeable? name version path)
591 (let ((output (or output "out")))
592 (call-with-values
593 (lambda ()
594 (specification->package+output name output))
595 list))))
596 (_ #f))
597 (manifest-entries manifest)))))
599 (define to-upgrade
600 (map (match-lambda
601 ((package output)
602 (package->manifest-entry* package output)))
603 packages-to-upgrade))
605 (define packages-to-install
606 (filter-map (match-lambda
607 (('install . (? package? p))
608 (list p "out"))
609 (('install . (? string? spec))
610 (and (not (store-path? spec))
611 (let-values (((package output)
612 (specification->package+output spec)))
613 (and package (list package output)))))
614 (_ #f))
615 opts))
617 (define to-install
618 (append (map (match-lambda
619 ((package output)
620 (package->manifest-entry* package output)))
621 packages-to-install)
622 (filter-map (match-lambda
623 (('install . (? package?))
624 #f)
625 (('install . (? store-path? path))
626 (let-values (((name version)
627 (package-name->name+version
628 (store-path-package-name path))))
629 (manifest-entry
630 (name name)
631 (version version)
632 (output #f)
633 (item path))))
634 (_ #f))
635 opts)))
637 (append to-upgrade to-install))
639 (define (options->removable options manifest)
640 "Given options, return the list of manifest patterns of packages to be
641 removed from MANIFEST."
642 (filter-map (match-lambda
643 (('remove . spec)
644 (call-with-values
645 (lambda ()
646 (package-specification->name+version+output spec))
647 (lambda (name version output)
648 (manifest-pattern
649 (name name)
650 (version version)
651 (output output)))))
652 (_ #f))
653 options))
655 (define (register-gc-root store profile)
656 "Register PROFILE, a profile generation symlink, as a GC root, unless it
657 doesn't need it."
658 (define absolute
659 ;; We must pass the daemon an absolute file name for PROFILE. However, we
660 ;; cannot use (canonicalize-path profile) because that would return us the
661 ;; target of PROFILE in the store; using a store item as an indirect root
662 ;; would mean that said store item will always remain live, which is not
663 ;; what we want here.
664 (if (string-prefix? "/" profile)
665 profile
666 (string-append (getcwd) "/" profile)))
668 (add-indirect-root store absolute))
670 (define (readlink* file)
671 "Call 'readlink' until the result is not a symlink."
672 (define %max-symlink-depth 50)
674 (let loop ((file file)
675 (depth 0))
676 (define (absolute target)
677 (if (absolute-file-name? target)
678 target
679 (string-append (dirname file) "/" target)))
681 (if (>= depth %max-symlink-depth)
682 file
683 (call-with-values
684 (lambda ()
685 (catch 'system-error
686 (lambda ()
687 (values #t (readlink file)))
688 (lambda args
689 (let ((errno (system-error-errno args)))
690 (if (or (= errno EINVAL))
691 (values #f file)
692 (apply throw args))))))
693 (lambda (success? target)
694 (if success?
695 (loop (absolute target) (+ depth 1))
696 file))))))
698 \f
699 ;;;
700 ;;; Entry point.
701 ;;;
703 (define (guix-package . args)
704 (define (handle-argument arg result arg-handler)
705 ;; Process non-option argument ARG by calling back ARG-HANDLER.
706 (if arg-handler
707 (arg-handler arg result)
708 (leave (_ "~A: extraneous argument~%") arg)))
710 (define (ensure-default-profile)
711 ;; Ensure the default profile symlink and directory exist and are
712 ;; writable.
714 (define (rtfm)
715 (format (current-error-port)
716 (_ "Try \"info '(guix) Invoking guix package'\" for \
717 more information.~%"))
718 (exit 1))
720 ;; Create ~/.guix-profile if it doesn't exist yet.
721 (when (and %user-profile-directory
722 %current-profile
723 (not (false-if-exception
724 (lstat %user-profile-directory))))
725 (symlink %current-profile %user-profile-directory))
727 (let ((s (stat %profile-directory #f)))
728 ;; Attempt to create /…/profiles/per-user/$USER if needed.
729 (unless (and s (eq? 'directory (stat:type s)))
730 (catch 'system-error
731 (lambda ()
732 (mkdir-p %profile-directory))
733 (lambda args
734 ;; Often, we cannot create %PROFILE-DIRECTORY because its
735 ;; parent directory is root-owned and we're running
736 ;; unprivileged.
737 (format (current-error-port)
738 (_ "error: while creating directory `~a': ~a~%")
739 %profile-directory
740 (strerror (system-error-errno args)))
741 (format (current-error-port)
742 (_ "Please create the `~a' directory, with you as the owner.~%")
743 %profile-directory)
744 (rtfm))))
746 ;; Bail out if it's not owned by the user.
747 (unless (or (not s) (= (stat:uid s) (getuid)))
748 (format (current-error-port)
749 (_ "error: directory `~a' is not owned by you~%")
750 %profile-directory)
751 (format (current-error-port)
752 (_ "Please change the owner of `~a' to user ~s.~%")
753 %profile-directory (or (getenv "USER")
754 (getenv "LOGNAME")
755 (getuid)))
756 (rtfm))))
758 (define (process-actions opts)
759 ;; Process any install/remove/upgrade action from OPTS.
761 (define dry-run? (assoc-ref opts 'dry-run?))
762 (define profile (assoc-ref opts 'profile))
764 (define (build-and-use-profile manifest)
765 (let* ((bootstrap? (assoc-ref opts 'bootstrap?)))
767 (when (equal? profile %current-profile)
768 (ensure-default-profile))
770 (let* ((prof-drv (run-with-store (%store)
771 (profile-derivation
772 manifest
773 #:hooks (if bootstrap?
774 '()
775 %default-profile-hooks))))
776 (prof (derivation->output-path prof-drv)))
777 (show-what-to-build (%store) (list prof-drv)
778 #:use-substitutes?
779 (assoc-ref opts 'substitutes?)
780 #:dry-run? dry-run?)
782 (cond
783 (dry-run? #t)
784 ((and (file-exists? profile)
785 (and=> (readlink* profile) (cut string=? prof <>)))
786 (format (current-error-port) (_ "nothing to be done~%")))
787 (else
788 (let* ((number (generation-number profile))
790 ;; Always use NUMBER + 1 for the new profile,
791 ;; possibly overwriting a "previous future
792 ;; generation".
793 (name (generation-file-name profile
794 (+ 1 number))))
795 (and (build-derivations (%store) (list prof-drv))
796 (let* ((entries (manifest-entries manifest))
797 (count (length entries)))
798 (switch-symlinks name prof)
799 (switch-symlinks profile name)
800 (unless (string=? profile %current-profile)
801 (register-gc-root (%store) name))
802 (format #t (N_ "~a package in profile~%"
803 "~a packages in profile~%"
804 count)
805 count)
806 (display-search-paths entries profile)))))))))
808 ;; First roll back if asked to.
809 (cond ((and (assoc-ref opts 'roll-back?)
810 (not dry-run?))
811 (roll-back (%store) profile)
812 (process-actions (alist-delete 'roll-back? opts)))
813 ((and (assoc-ref opts 'switch-generation)
814 (not dry-run?))
815 (for-each
816 (match-lambda
817 (('switch-generation . pattern)
818 (let* ((number (string->number pattern))
819 (number (and number
820 (case (string-ref pattern 0)
821 ((#\+ #\-)
822 (relative-generation profile number))
823 (else number)))))
824 (if number
825 (switch-to-generation profile number)
826 (leave (_ "cannot switch to generation '~a'~%")
827 pattern)))
828 (process-actions (alist-delete 'switch-generation opts)))
829 (_ #f))
830 opts))
831 ((and (assoc-ref opts 'delete-generations)
832 (not dry-run?))
833 (for-each
834 (match-lambda
835 (('delete-generations . pattern)
836 (delete-matching-generations (%store) profile pattern)
838 (process-actions
839 (alist-delete 'delete-generations opts)))
840 (_ #f))
841 opts))
842 ((assoc-ref opts 'manifest)
843 (let* ((file-name (assoc-ref opts 'manifest))
844 (user-module (make-user-module '((guix profiles)
845 (gnu))))
846 (manifest (load* file-name user-module)))
847 (if (assoc-ref opts 'dry-run?)
848 (format #t (_ "would install new manifest from '~a' with ~d entries~%")
849 file-name (length (manifest-entries manifest)))
850 (format #t (_ "installing new manifest from '~a' with ~d entries~%")
851 file-name (length (manifest-entries manifest))))
852 (build-and-use-profile manifest)))
853 (else
854 (let* ((manifest (profile-manifest profile))
855 (install (options->installable opts manifest))
856 (remove (options->removable opts manifest))
857 (transaction (manifest-transaction (install install)
858 (remove remove)))
859 (new (manifest-perform-transaction
860 manifest transaction)))
862 (unless (and (null? install) (null? remove))
863 (show-manifest-transaction (%store) manifest transaction
864 #:dry-run? dry-run?)
865 (build-and-use-profile new))))))
867 (define (process-query opts)
868 ;; Process any query specified by OPTS. Return #t when a query was
869 ;; actually processed, #f otherwise.
870 (let ((profile (assoc-ref opts 'profile)))
871 (match (assoc-ref opts 'query)
872 (('list-generations pattern)
873 (define (list-generation number)
874 (unless (zero? number)
875 (let ((header (format #f (_ "Generation ~a\t~a") number
876 (date->string
877 (time-utc->date
878 (generation-time profile number))
879 "~b ~d ~Y ~T")))
880 (current (generation-number profile)))
881 (if (= number current)
882 (format #t (_ "~a\t(current)~%") header)
883 (format #t "~a~%" header)))
884 (for-each (match-lambda
885 (($ <manifest-entry> name version output location _)
886 (format #t " ~a\t~a\t~a\t~a~%"
887 name version output location)))
889 ;; Show most recently installed packages last.
890 (reverse
891 (manifest-entries
892 (profile-manifest
893 (generation-file-name profile number)))))
894 (newline)))
896 (cond ((not (file-exists? profile)) ; XXX: race condition
897 (raise (condition (&profile-not-found-error
898 (profile profile)))))
899 ((string-null? pattern)
900 (for-each list-generation (profile-generations profile)))
901 ((matching-generations pattern profile)
902 =>
903 (lambda (numbers)
904 (if (null-list? numbers)
905 (exit 1)
906 (leave-on-EPIPE
907 (for-each list-generation numbers)))))
908 (else
909 (leave (_ "invalid syntax: ~a~%")
910 pattern)))
911 #t)
913 (('list-installed regexp)
914 (let* ((regexp (and regexp (make-regexp regexp)))
915 (manifest (profile-manifest profile))
916 (installed (manifest-entries manifest)))
917 (leave-on-EPIPE
918 (for-each (match-lambda
919 (($ <manifest-entry> name version output path _)
920 (when (or (not regexp)
921 (regexp-exec regexp name))
922 (format #t "~a\t~a\t~a\t~a~%"
923 name (or version "?") output path))))
925 ;; Show most recently installed packages last.
926 (reverse installed)))
927 #t))
929 (('list-available regexp)
930 (let* ((regexp (and regexp (make-regexp regexp)))
931 (available (fold-packages
932 (lambda (p r)
933 (let ((n (package-name p)))
934 (if (supported-package? p)
935 (if regexp
936 (if (regexp-exec regexp n)
937 (cons p r)
938 r)
939 (cons p r))
940 r)))
941 '())))
942 (leave-on-EPIPE
943 (for-each (lambda (p)
944 (format #t "~a\t~a\t~a\t~a~%"
945 (package-name p)
946 (package-version p)
947 (string-join (package-outputs p) ",")
948 (location->string (package-location p))))
949 (sort available
950 (lambda (p1 p2)
951 (string<? (package-name p1)
952 (package-name p2))))))
953 #t))
955 (('search regexp)
956 (let ((regexp (make-regexp regexp regexp/icase)))
957 (leave-on-EPIPE
958 (for-each (cute package->recutils <> (current-output-port))
959 (find-packages-by-description regexp)))
960 #t))
962 (('show requested-name)
963 (let-values (((name version)
964 (package-name->name+version requested-name)))
965 (leave-on-EPIPE
966 (for-each (cute package->recutils <> (current-output-port))
967 (find-packages-by-name name version)))
968 #t))
970 (('search-paths kind)
971 (let* ((manifest (profile-manifest profile))
972 (entries (manifest-entries manifest))
973 (profile (user-friendly-profile profile))
974 (settings (search-path-environment-variables entries profile
975 (const #f)
976 #:kind kind)))
977 (format #t "~{~a~%~}" settings)
978 #t))
980 (_ #f))))
982 (let ((opts (parse-command-line args %options (list %default-options #f)
983 #:argument-handler handle-argument)))
984 (with-error-handling
985 (or (process-query opts)
986 (parameterize ((%store (open-connection)))
987 (set-build-options-from-command-line (%store) opts)
989 (parameterize ((%guile-for-build
990 (package-derivation
991 (%store)
992 (if (assoc-ref opts 'bootstrap?)
993 %bootstrap-guile
994 (canonical-package guile-2.0)))))
995 (process-actions opts)))))))