;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; 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.
#: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)
+ #:use-module (guix scripts)
#:use-module (guix scripts build)
#:use-module ((guix build utils)
#:select (directory-exists? mkdir-p search-path-as-list))
#:use-module (gnu packages base)
#:use-module (gnu packages guile)
#:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
- #:export (specification->package+output
- switch-to-generation
+ #:export (switch-to-generation
switch-to-previous-generation
roll-back
delete-generation
delete-generations
+ display-search-paths
guix-package))
(define %store
%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
(for-each (cut delete-generation store profile <>)
generations))
-(define* (matching-generations str #:optional (profile %current-profile)
- #:key (duration-relation <=))
- "Return the list of available generations matching a pattern in STR. See
-'string->generations' and 'string->duration' for the list of valid patterns.
-When STR is a duration pattern, return all the generations whose ctime has
-DURATION-RELATION with the current time."
- (define (valid-generations lst)
- (define (valid-generation? n)
- (any (cut = n <>) (generation-numbers profile)))
-
- (fold-right (lambda (x acc)
- (if (valid-generation? x)
- (cons x acc)
- acc))
- '()
- lst))
-
- (define (filter-generations generations)
- (match generations
- (() '())
- (('>= n)
- (drop-while (cut > n <>)
- (generation-numbers profile)))
- (('<= n)
- (valid-generations (iota n 1)))
- ((lst ..1)
- (valid-generations lst))
- (_ #f)))
-
- (define (filter-by-duration duration)
- (define (time-at-midnight time)
- ;; Return TIME at midnight by setting nanoseconds, seconds, minutes, and
- ;; hours to zeros.
- (let ((d (time-utc->date time)))
- (date->time-utc
- (make-date 0 0 0 0
- (date-day d) (date-month d)
- (date-year d) (date-zone-offset d)))))
-
- (define generation-ctime-alist
- (map (lambda (number)
- (cons number
- (time-second
- (time-at-midnight
- (generation-time profile number)))))
- (generation-numbers profile)))
-
- (match duration
- (#f #f)
- (res
- (let ((s (time-second
- (subtract-duration (time-at-midnight (current-time))
- duration))))
- (delete #f (map (lambda (x)
- (and (duration-relation s (cdr x))
- (first x)))
- generation-ctime-alist))))))
-
- (cond ((string->generations str)
- =>
- filter-generations)
- ((string->duration str)
- =>
- 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)))))
\f
;;;
(define (find-packages-by-description rx)
"Return the list of packages whose name, synopsis, or description matches
RX."
- (define (same-location? p1 p2)
- ;; Compare locations of two packages.
- (equal? (package-location p1) (package-location p2)))
-
- (delete-duplicates
- (sort
- (fold-packages (lambda (package result)
- (define matches?
- (cut regexp-exec rx <>))
-
- (if (or (matches? (package-name package))
- (and=> (package-synopsis package)
- (compose matches? P_))
- (and=> (package-description package)
- (compose matches? P_)))
- (cons package result)
- result))
- '())
- (lambda (p1 p2)
- (string<? (package-name p1)
- (package-name p2))))
- same-location?))
-
-(define-syntax-rule (leave-on-EPIPE exp ...)
- "Run EXP... in a context when EPIPE errors are caught and lead to 'exit'
-with successful exit code. This is useful when writing to the standard output
-may lead to EPIPE, because the standard output is piped through 'head' or
-similar."
- (catch 'system-error
- (lambda ()
- exp ...)
- (lambda args
- ;; We really have to exit this brutally, otherwise Guile eventually
- ;; attempts to flush all the ports, leading to an uncaught EPIPE down
- ;; the path.
- (if (= EPIPE (system-error-errno args))
- (primitive-_exit 0)
- (apply throw args)))))
-
-(define* (specification->package+output spec #:optional (output "out"))
- "Return the package and output specified by SPEC, or #f and #f; SPEC may
-optionally contain a version number and an output name, as in these examples:
-
- guile
- guile-2.0.9
- guile:debug
- guile-2.0.9:debug
-
-If SPEC does not specify a version number, return the preferred newest
-version; if SPEC does not specify an output, return OUTPUT."
- (define (ensure-output p sub-drv)
- (if (member sub-drv (package-outputs p))
- sub-drv
- (leave (_ "package `~a' lacks output `~a'~%")
- (package-full-name p)
- sub-drv)))
-
- (let-values (((name version sub-drv)
- (package-specification->name+version+output spec output)))
- (match (find-best-packages-by-name name version)
- ((p)
- (values p (ensure-output p sub-drv)))
- ((p p* ...)
- (warning (_ "ambiguous package specification `~a'~%")
- spec)
- (warning (_ "choosing ~a from ~a~%")
- (package-full-name p)
- (location->string (package-location p)))
- (values p (ensure-output p sub-drv)))
- (()
- (leave (_ "~a: package not found~%") spec)))))
+ (define version<? (negate version>=?))
+
+ (sort
+ (fold-packages (lambda (package result)
+ (define matches?
+ (cut regexp-exec rx <>))
+
+ (if (or (matches? (package-name package))
+ (and=> (package-synopsis package)
+ (compose matches? P_))
+ (and=> (package-description package)
+ (compose matches? P_)))
+ (cons package result)
+ result))
+ '())
+ (lambda (p1 p2)
+ (case (string-compare (package-name p1) (package-name p2)
+ (const '<) (const '=) (const '>))
+ ((=) (version<? (package-version p1) (package-version p2)))
+ ((<) #t)
+ (else #f)))))
(define (upgradeable? name current-version current-path)
"Return #t if there's a version of package NAME newer than CURRENT-VERSION,
;;;
(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))
- '()))
- (path (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))))
(substitutes? . #t)))
(define (show-help)
- (display (_ "Usage: guix package [OPTION]... PACKAGES...
-Install, remove, or upgrade PACKAGES in a single transaction.\n"))
+ (display (_ "Usage: guix package [OPTION]...
+Install, remove, or upgrade packages in a single transaction.\n"))
(display (_ "
- -i, --install=PACKAGE install PACKAGE"))
+ -i, --install PACKAGE ...
+ install PACKAGEs"))
(display (_ "
-e, --install-from-expression=EXP
install the package EXP evaluates to"))
(display (_ "
- -r, --remove=PACKAGE remove PACKAGE"))
+ -f, --install-from-file=FILE
+ install the package that the code within FILE
+ evaluates to"))
+ (display (_ "
+ -r, --remove PACKAGE ...
+ remove PACKAGEs"))
(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"))
-A, --list-available[=REGEXP]
list available packages matching REGEXP"))
(display (_ "
- --show=PACKAGE show details about PACKAGE"))
+ --show=PACKAGE show details about PACKAGE"))
(newline)
(show-build-options-help)
(newline)
(values (alist-cons 'install (read/eval-package-expression arg)
result)
#f)))
+ (option '(#\f "install-from-file") #t #f
+ (lambda (opt name arg result arg-handler)
+ (values (alist-cons 'install
+ (load* arg (make-user-module '()))
+ result)
+ #f)))
(option '(#\r "remove") #f #t
(lambda (opt name arg result arg-handler)
(let arg-handler ((arg arg) (result result))
;; 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 ""))
(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)
(_ #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
(()
(($ <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
(_ #f))
options))
-(define (maybe-register-gc-root store profile)
- "Register PROFILE as a GC root, unless it doesn't need it."
- (unless (string=? profile %current-profile)
- (add-indirect-root store (canonicalize-path profile))))
-
-(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 (register-gc-root store profile)
+ "Register PROFILE, a profile generation symlink, as a GC root, unless it
+doesn't need it."
+ (define absolute
+ ;; We must pass the daemon an absolute file name for PROFILE. However, we
+ ;; cannot use (canonicalize-path profile) because that would return us the
+ ;; target of PROFILE in the store; using a store item as an indirect root
+ ;; would mean that said store item will always remain live, which is not
+ ;; what we want here.
+ (if (string-prefix? "/" profile)
+ profile
+ (string-append (getcwd) "/" profile)))
+
+ (add-indirect-root store absolute))
\f
;;;
;;;
(define (guix-package . args)
- (define (parse-options)
- ;; Return the alist of option values.
- (append (parse-options-from args)
- (parse-options-from (environment-build-options))))
-
- (define (parse-options-from args)
- ;; Actual parsing takes place here.
- (args-fold* args %options
- (lambda (opt name arg result arg-handler)
- (leave (_ "~A: unrecognized option~%") name))
- (lambda (arg result arg-handler)
- (if arg-handler
- (arg-handler arg result)
- (leave (_ "~A: extraneous argument~%") arg)))
- %default-options
- #f))
+ (define (handle-argument arg result arg-handler)
+ ;; Process non-option argument ARG by calling back ARG-HANDLER.
+ (if arg-handler
+ (arg-handler arg result)
+ (leave (_ "~A: extraneous argument~%") arg)))
(define (ensure-default-profile)
;; Ensure the default profile symlink and directory exist and are
(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?)
(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))
+ ((assoc-ref opts 'manifest)
+ (let* ((file-name (assoc-ref opts 'manifest))
+ (user-module (make-user-module '((guix profiles)
+ (gnu))))
+ (manifest (load* file-name user-module)))
+ (if (assoc-ref opts 'dry-run?)
+ (format #t (_ "would install new manifest from '~a' with ~d entries~%")
+ file-name (length (manifest-entries manifest)))
+ (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?))))
- (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)
- (maybe-register-gc-root (%store) profile)
- (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
(('list-generations pattern)
(define (list-generation number)
(unless (zero? number)
- (let ((header (format #f (_ "Generation ~a\t~a") number
- (date->string
- (time-utc->date
- (generation-time profile number))
- "~b ~d ~Y ~T")))
- (current (generation-number profile)))
- (if (= number current)
- (format #t (_ "~a\t(current)~%") header)
- (format #t "~a~%" header)))
- (for-each (match-lambda
- (($ <manifest-entry> name version output location _)
- (format #t " ~a\t~a\t~a\t~a~%"
- name version output location)))
-
- ;; Show most recently installed packages last.
- (reverse
- (manifest-entries
- (profile-manifest
- (generation-file-name profile number)))))
+ (display-generation profile number)
+ (display-profile-content profile number)
(newline)))
(cond ((not (file-exists? profile)) ; XXX: race condition
(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)
(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))
(_ #f))))
- (let ((opts (parse-options)))
+ (let ((opts (parse-command-line args %options (list %default-options #f)
+ #:argument-handler handle-argument)))
(with-error-handling
(or (process-query opts)
(parameterize ((%store (open-connection)))
HCoop / jackhill / guix / guix.git / blobdiff