summaryrefslogtreecommitdiff
path: root/guix/scripts/package.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/scripts/package.scm')
-rw-r--r--guix/scripts/package.scm356
1 files changed, 202 insertions, 154 deletions
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 3cc7ae760f..06ee441799 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
-;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
;;;
;;; This file is part of GNU Guix.
@@ -25,6 +25,7 @@
#:use-module (guix derivations)
#:use-module (guix packages)
#:use-module (guix profiles)
+ #:use-module (guix search-paths)
#:use-module (guix monads)
#:use-module (guix utils)
#:use-module (guix config)
@@ -89,6 +90,15 @@ return PROFILE unchanged. The goal is to treat '-p ~/.guix-profile' as if
%current-profile
profile))
+(define (user-friendly-profile profile)
+ "Return either ~/.guix-profile if that's what PROFILE refers to, directly or
+indirectly, or PROFILE."
+ (if (and %user-profile-directory
+ (false-if-exception
+ (string=? (readlink %user-profile-directory) profile)))
+ %user-profile-directory
+ profile))
+
(define (link-to-empty-profile store generation)
"Link GENERATION, a string, to the empty profile."
(let* ((drv (run-with-store store
@@ -232,6 +242,41 @@ DURATION-RELATION with the current time."
filter-by-duration)
(else #f)))
+(define (delete-matching-generations store profile pattern)
+ "Delete from PROFILE all the generations matching PATTERN. PATTERN must be
+a string denoting a set of generations: the empty list means \"all generations
+but the current one\", a number designates a generation, and other patterns
+denote ranges as interpreted by 'matching-derivations'."
+ (let ((current (generation-number profile)))
+ (cond ((not (file-exists? profile)) ; XXX: race condition
+ (raise (condition (&profile-not-found-error
+ (profile profile)))))
+ ((string-null? pattern)
+ (delete-generations (%store) profile
+ (delv current (profile-generations profile))))
+ ;; Do not delete the zeroth generation.
+ ((equal? 0 (string->number pattern))
+ #t)
+
+ ;; If PATTERN is a duration, match generations that are
+ ;; older than the specified duration.
+ ((matching-generations pattern profile
+ #:duration-relation >)
+ =>
+ (lambda (numbers)
+ (when (memv current numbers)
+ (warning (_ "not removing generation ~a, which is current~%")
+ current))
+
+ ;; Make sure we don't inadvertently remove the current
+ ;; generation.
+ (let ((numbers (delv current numbers)))
+ (when (null-list? numbers)
+ (leave (_ "no matching generation~%")))
+ (delete-generations (%store) profile numbers))))
+ (else
+ (leave (_ "invalid syntax: ~a~%") pattern)))))
+
;;;
;;; Package specifications.
@@ -330,77 +375,35 @@ an output path different than CURRENT-PATH."
;;; Search paths.
;;;
-(define-syntax-rule (with-null-error-port exp)
- "Evaluate EXP with the error port pointing to the bit bucket."
- (with-error-to-port (%make-void-port "w")
- (lambda () exp)))
-
(define* (search-path-environment-variables entries profile
- #:optional (getenv getenv))
+ #:optional (getenv getenv)
+ #:key (kind 'exact))
"Return environment variable definitions that may be needed for the use of
ENTRIES, a list of manifest entries, in PROFILE. Use GETENV to determine the
-current settings and report only settings not already effective."
-
- ;; Prefer ~/.guix-profile to the real profile directory name.
- (let ((profile (if (and %user-profile-directory
- (false-if-exception
- (string=? (readlink %user-profile-directory)
- profile)))
- %user-profile-directory
- profile)))
-
- ;; The search path info is not stored in the manifest. Thus, we infer the
- ;; search paths from same-named packages found in the distro.
-
- (define manifest-entry->package
- (match-lambda
- (($ <manifest-entry> name version)
- ;; Use 'find-best-packages-by-name' and not 'find-packages-by-name';
- ;; the former traverses the module tree only once and then allows for
- ;; efficient access via a vhash.
- (match (find-best-packages-by-name name version)
- ((p _ ...) p)
- (_
- (match (find-best-packages-by-name name #f)
- ((p _ ...) p)
- (_ #f)))))))
-
- (define search-path-definition
- (match-lambda
- (($ <search-path-specification> variable files separator
- type pattern)
- (let* ((values (or (and=> (getenv variable)
- (cut string-tokenize* <> separator))
- '()))
- ;; Add a trailing slash to force symlinks to be treated as
- ;; directories when 'find-files' traverses them.
- (files (if pattern
- (map (cut string-append <> "/") files)
- files))
-
- ;; XXX: Silence 'find-files' when it stumbles upon non-existent
- ;; directories (see
- ;; <http://lists.gnu.org/archive/html/guix-devel/2015-01/msg00269.html>.)
- (path (with-null-error-port
- (search-path-as-list files (list profile)
- #:type type
- #:pattern pattern))))
- (if (every (cut member <> values) path)
- #f
- (format #f "export ~a=\"~a\""
- variable
- (string-join path separator)))))))
-
- (let* ((packages (filter-map manifest-entry->package entries))
- (search-paths (delete-duplicates
- (append-map package-native-search-paths
- packages))))
- (filter-map search-path-definition search-paths))))
-
-(define (display-search-paths entries profile)
+current settings and report only settings not already effective. KIND
+must be one of 'exact, 'prefix, or 'suffix, depending on the kind of search
+path definition to be returned."
+ (let ((search-paths (delete-duplicates
+ (cons $PATH
+ (append-map manifest-entry-search-paths
+ entries)))))
+ (filter-map (match-lambda
+ ((spec . value)
+ (let ((variable (search-path-specification-variable spec))
+ (sep (search-path-specification-separator spec)))
+ (environment-variable-definition variable value
+ #:separator sep
+ #:kind kind))))
+ (evaluate-search-paths search-paths (list profile)
+ getenv))))
+
+(define* (display-search-paths entries profile
+ #:key (kind 'exact))
"Display the search path environment variables that may need to be set for
ENTRIES, a list of manifest entries, in the context of PROFILE."
- (let ((settings (search-path-environment-variables entries profile)))
+ (let* ((profile (user-friendly-profile profile))
+ (settings (search-path-environment-variables entries profile
+ #:kind kind)))
(unless (null? settings)
(format #t (_ "The following environment variable definitions may be needed:~%"))
(format #t "~{ ~a~%~}" settings))))
@@ -430,9 +433,15 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(display (_ "
-u, --upgrade[=REGEXP] upgrade all the installed packages matching REGEXP"))
(display (_ "
+ -m, --manifest=FILE create a new profile generation with the manifest
+ from FILE"))
+ (display (_ "
+ --do-not-upgrade[=REGEXP] do not upgrade any packages matching REGEXP"))
+ (display (_ "
--roll-back roll back to the previous generation"))
(display (_ "
- --search-paths display needed environment variable definitions"))
+ --search-paths[=KIND]
+ display needed environment variable definitions"))
(display (_ "
-l, --list-generations[=PATTERN]
list generations matching PATTERN"))
@@ -508,10 +517,21 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
;; would upgrade everything.
(delete '(upgrade . #f) result))
arg-handler))))
+ (option '("do-not-upgrade") #f #t
+ (lambda (opt name arg result arg-handler)
+ (let arg-handler ((arg arg) (result result))
+ (values (if arg
+ (alist-cons 'do-not-upgrade arg result)
+ result)
+ arg-handler))))
(option '("roll-back") #f #f
(lambda (opt name arg result arg-handler)
(values (alist-cons 'roll-back? #t result)
#f)))
+ (option '(#\m "manifest") #t #f
+ (lambda (opt name arg result arg-handler)
+ (values (alist-cons 'manifest arg result)
+ arg-handler)))
(option '(#\l "list-generations") #f #t
(lambda (opt name arg result arg-handler)
(values (cons `(query list-generations ,(or arg ""))
@@ -526,10 +546,20 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(lambda (opt name arg result arg-handler)
(values (alist-cons 'switch-generation arg result)
#f)))
- (option '("search-paths") #f #f
+ (option '("search-paths") #f #t
(lambda (opt name arg result arg-handler)
- (values (cons `(query search-paths) result)
- #f)))
+ (let ((kind (match arg
+ ((or "exact" "prefix" "suffix")
+ (string->symbol arg))
+ (#f
+ 'exact)
+ (x
+ (leave (_ "~a: unsupported \
+kind of search path~%")
+ x)))))
+ (values (cons `(query search-paths ,kind)
+ result)
+ #f))))
(option '(#\p "profile") #t #f
(lambda (opt name arg result arg-handler)
(values (alist-cons 'profile (canonicalize-profile arg)
@@ -586,6 +616,13 @@ return the new list of manifest entries."
(_ #f))
opts))
+ (define do-not-upgrade-regexps
+ (filter-map (match-lambda
+ (('do-not-upgrade . regexp)
+ (make-regexp regexp))
+ (_ #f))
+ opts))
+
(define packages-to-upgrade
(match upgrade-regexps
(()
@@ -595,6 +632,8 @@ return the new list of manifest entries."
(($ <manifest-entry> name version output path _)
(and (any (cut regexp-exec <> name)
upgrade-regexps)
+ (not (any (cut regexp-exec <> name)
+ do-not-upgrade-regexps))
(upgradeable? name version path)
(let ((output (or output "out")))
(call-with-values
@@ -677,13 +716,31 @@ doesn't need it."
(define (readlink* file)
"Call 'readlink' until the result is not a symlink."
- (catch 'system-error
- (lambda ()
- (readlink* (readlink file)))
- (lambda args
- (if (= EINVAL (system-error-errno args))
- file
- (apply throw args)))))
+ (define %max-symlink-depth 50)
+
+ (let loop ((file file)
+ (depth 0))
+ (define (absolute target)
+ (if (absolute-file-name? target)
+ target
+ (string-append (dirname file) "/" target)))
+
+ (if (>= depth %max-symlink-depth)
+ file
+ (call-with-values
+ (lambda ()
+ (catch 'system-error
+ (lambda ()
+ (values #t (readlink file)))
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (if (or (= errno EINVAL))
+ (values #f file)
+ (apply throw args))))))
+ (lambda (success? target)
+ (if success?
+ (loop (absolute target) (+ depth 1))
+ file))))))
;;;
@@ -751,8 +808,49 @@ more information.~%"))
(define dry-run? (assoc-ref opts 'dry-run?))
(define profile (assoc-ref opts 'profile))
- (define current-generation-number
- (generation-number profile))
+ (define (build-and-use-profile manifest)
+ (let* ((bootstrap? (assoc-ref opts 'bootstrap?)))
+
+ (when (equal? profile %current-profile)
+ (ensure-default-profile))
+
+ (let* ((prof-drv (run-with-store (%store)
+ (profile-derivation
+ manifest
+ #:hooks (if bootstrap?
+ '()
+ %default-profile-hooks))))
+ (prof (derivation->output-path prof-drv)))
+ (show-what-to-build (%store) (list prof-drv)
+ #:use-substitutes?
+ (assoc-ref opts 'substitutes?)
+ #:dry-run? dry-run?)
+
+ (cond
+ (dry-run? #t)
+ ((and (file-exists? profile)
+ (and=> (readlink* profile) (cut string=? prof <>)))
+ (format (current-error-port) (_ "nothing to be done~%")))
+ (else
+ (let* ((number (generation-number profile))
+
+ ;; Always use NUMBER + 1 for the new profile,
+ ;; possibly overwriting a "previous future
+ ;; generation".
+ (name (generation-file-name profile
+ (+ 1 number))))
+ (and (build-derivations (%store) (list prof-drv))
+ (let* ((entries (manifest-entries manifest))
+ (count (length entries)))
+ (switch-symlinks name prof)
+ (switch-symlinks profile name)
+ (unless (string=? profile %current-profile)
+ (register-gc-root (%store) name))
+ (format #t (N_ "~a package in profile~%"
+ "~a packages in profile~%"
+ count)
+ count)
+ (display-search-paths entries profile)))))))))
;; First roll back if asked to.
(cond ((and (assoc-ref opts 'roll-back?)
@@ -782,88 +880,34 @@ more information.~%"))
(for-each
(match-lambda
(('delete-generations . pattern)
- (cond ((not (file-exists? profile)) ; XXX: race condition
- (raise (condition (&profile-not-found-error
- (profile profile)))))
- ((string-null? pattern)
- (delete-generations
- (%store) profile
- (delete current-generation-number
- (profile-generations profile))))
- ;; Do not delete the zeroth generation.
- ((equal? 0 (string->number pattern))
- (exit 0))
-
- ;; If PATTERN is a duration, match generations that are
- ;; older than the specified duration.
- ((matching-generations pattern profile
- #:duration-relation >)
- =>
- (lambda (numbers)
- (if (null-list? numbers)
- (exit 1)
- (delete-generations (%store) profile numbers))))
- (else
- (leave (_ "invalid syntax: ~a~%")
- pattern)))
+ (delete-matching-generations (%store) profile pattern)
(process-actions
(alist-delete 'delete-generations opts)))
(_ #f))
opts))
+ ((and (assoc-ref opts 'manifest)
+ (not dry-run?))
+ (let* ((file-name (assoc-ref opts 'manifest))
+ (user-module (make-user-module '((guix profiles)
+ (gnu))))
+ (manifest (load* file-name user-module)))
+ (format #t (_ "installing new manifest from ~a with ~d entries.~%")
+ file-name (length (manifest-entries manifest)))
+ (build-and-use-profile manifest)))
(else
(let* ((manifest (profile-manifest profile))
(install (options->installable opts manifest))
(remove (options->removable opts manifest))
- (bootstrap? (assoc-ref opts 'bootstrap?))
(transaction (manifest-transaction (install install)
(remove remove)))
(new (manifest-perform-transaction
manifest transaction)))
- (when (equal? profile %current-profile)
- (ensure-default-profile))
-
(unless (and (null? install) (null? remove))
- (let* ((prof-drv (run-with-store (%store)
- (profile-derivation
- new
- #:info-dir? (not bootstrap?)
- #:ca-certificate-bundle? (not bootstrap?))))
- (prof (derivation->output-path prof-drv)))
- (show-manifest-transaction (%store) manifest transaction
- #:dry-run? dry-run?)
- (show-what-to-build (%store) (list prof-drv)
- #:use-substitutes?
- (assoc-ref opts 'substitutes?)
- #:dry-run? dry-run?)
-
- (cond
- (dry-run? #t)
- ((and (file-exists? profile)
- (and=> (readlink* profile) (cut string=? prof <>)))
- (format (current-error-port) (_ "nothing to be done~%")))
- (else
- (let* ((number (generation-number profile))
-
- ;; Always use NUMBER + 1 for the new profile,
- ;; possibly overwriting a "previous future
- ;; generation".
- (name (generation-file-name profile
- (+ 1 number))))
- (and (build-derivations (%store) (list prof-drv))
- (let* ((entries (manifest-entries new))
- (count (length entries)))
- (switch-symlinks name prof)
- (switch-symlinks profile name)
- (unless (string=? profile %current-profile)
- (register-gc-root (%store) name))
- (format #t (N_ "~a package in profile~%"
- "~a packages in profile~%"
- count)
- count)
- (display-search-paths entries
- profile))))))))))))
+ (show-manifest-transaction (%store) manifest transaction
+ #:dry-run? dry-run?)
+ (build-and-use-profile new))))))
(define (process-query opts)
;; Process any query specified by OPTS. Return #t when a query was
@@ -932,11 +976,13 @@ more information.~%"))
(available (fold-packages
(lambda (p r)
(let ((n (package-name p)))
- (if regexp
- (if (regexp-exec regexp n)
- (cons p r)
- r)
- (cons p r))))
+ (if (supported-package? p)
+ (if regexp
+ (if (regexp-exec regexp n)
+ (cons p r)
+ r)
+ (cons p r))
+ r)))
'())))
(leave-on-EPIPE
(for-each (lambda (p)
@@ -966,11 +1012,13 @@ more information.~%"))
(find-packages-by-name name version)))
#t))
- (('search-paths)
+ (('search-paths kind)
(let* ((manifest (profile-manifest profile))
(entries (manifest-entries manifest))
+ (profile (user-friendly-profile profile))
(settings (search-path-environment-variables entries profile
- (const #f))))
+ (const #f)
+ #:kind kind)))
(format #t "~{~a~%~}" settings)
#t))