;;; 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))
- #:use-module ((guix ftp-client) #:select (ftp-open))
+ #:use-module ((guix build utils)
+ #:select (directory-exists? mkdir-p search-path-as-list))
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module (srfi srfi-37)
#:use-module (gnu packages)
- #:use-module ((gnu packages base) #:select (guile-final))
+ #:use-module (gnu packages base)
+ #:use-module (gnu packages guile)
#:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
- #:use-module (guix gnu-maintenance)
- #:export (specification->package+output
+ #:export (switch-to-generation
+ switch-to-previous-generation
+ roll-back
+ delete-generation
+ delete-generations
+ display-search-paths
guix-package))
(define %store
(define %profile-directory
(string-append %state-directory "/profiles/"
- (or (and=> (getenv "USER")
+ (or (and=> (or (getenv "USER")
+ (getenv "LOGNAME"))
(cut string-append "per-user/" <>))
"default")))
;; coexist with Nix profiles.
(string-append %profile-directory "/guix-profile"))
-(define (link-to-empty-profile generation)
+(define (canonicalize-profile profile)
+ "If PROFILE is %USER-PROFILE-DIRECTORY, return %CURRENT-PROFILE. Otherwise
+return PROFILE unchanged. The goal is to treat '-p ~/.guix-profile' as if
+'-p' was omitted." ; see <http://bugs.gnu.org/17939>
+ (if (and %user-profile-directory
+ (string=? (canonicalize-path (dirname profile))
+ (dirname %user-profile-directory))
+ (string=? (basename profile) (basename %user-profile-directory)))
+ %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 (profile-derivation (%store) (manifest '())))
+ (let* ((drv (run-with-store store
+ (profile-derivation (manifest '()))))
(prof (derivation->output-path drv "out")))
- (when (not (build-derivations (%store) (list drv)))
+ (when (not (build-derivations store (list drv)))
(leave (_ "failed to build the empty profile~%")))
(switch-symlinks generation prof)))
+(define (switch-to-generation profile number)
+ "Atomically switch PROFILE to the generation NUMBER."
+ (let ((current (generation-number profile))
+ (generation (generation-file-name profile number)))
+ (cond ((not (file-exists? profile))
+ (raise (condition (&profile-not-found-error
+ (profile profile)))))
+ ((not (file-exists? generation))
+ (raise (condition (&missing-generation-error
+ (profile profile)
+ (generation number)))))
+ (else
+ (format #t (_ "switching from generation ~a to ~a~%")
+ current number)
+ (switch-symlinks profile generation)))))
+
(define (switch-to-previous-generation profile)
"Atomically switch PROFILE to the previous generation."
- (let* ((number (generation-number profile))
- (previous-number (previous-generation-number profile number))
- (previous-generation (generation-file-name profile previous-number)))
- (format #t (_ "switching from generation ~a to ~a~%")
- number previous-number)
- (switch-symlinks profile previous-generation)))
+ (switch-to-generation profile
+ (previous-generation-number profile)))
-(define (roll-back profile)
+(define (roll-back store profile)
"Roll back to the previous generation of PROFILE."
(let* ((number (generation-number profile))
(previous-number (previous-generation-number profile number))
- (previous-generation (generation-file-name profile previous-number))
- (manifest (string-append previous-generation "/manifest")))
+ (previous-generation (generation-file-name profile previous-number)))
(cond ((not (file-exists? profile)) ; invalid profile
- (leave (_ "profile '~a' does not exist~%")
- profile))
+ (raise (condition (&profile-not-found-error
+ (profile profile)))))
((zero? number) ; empty profile
(format (current-error-port)
(_ "nothing to do: already at the empty profile~%")))
((or (zero? previous-number) ; going to emptiness
(not (file-exists? previous-generation)))
- (link-to-empty-profile previous-generation)
+ (link-to-empty-profile store previous-generation)
(switch-to-previous-generation profile))
(else
(switch-to-previous-generation profile))))) ; anything else
-(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 (show-what-to-remove/install remove install dry-run?)
- "Given the manifest entries listed in REMOVE and INSTALL, display the
-packages that will/would be installed and removed."
- ;; TODO: Report upgrades more clearly.
- (match remove
- ((($ <manifest-entry> name version output path _) ..1)
- (let ((len (length name))
- (remove (map (cut format #f " ~a-~a\t~a\t~a" <> <> <> <>)
- name version output path)))
- (if dry-run?
- (format (current-error-port)
- (N_ "The following package would be removed:~%~{~a~%~}~%"
- "The following packages would be removed:~%~{~a~%~}~%"
- len)
- remove)
- (format (current-error-port)
- (N_ "The following package will be removed:~%~{~a~%~}~%"
- "The following packages will be removed:~%~{~a~%~}~%"
- len)
- remove))))
- (_ #f))
- (match install
- ((($ <manifest-entry> name version output path _) ..1)
- (let ((len (length name))
- (install (map (cut format #f " ~a-~a\t~a\t~a" <> <> <> <>)
- name version output path)))
- (if dry-run?
- (format (current-error-port)
- (N_ "The following package would be installed:~%~{~a~%~}~%"
- "The following packages would be installed:~%~{~a~%~}~%"
- len)
- install)
- (format (current-error-port)
- (N_ "The following package will be installed:~%~{~a~%~}~%"
- "The following packages will be installed:~%~{~a~%~}~%"
- len)
- install))))
- (_ #f)))
+(define (delete-generation store profile number)
+ "Delete generation with NUMBER from PROFILE."
+ (define (display-and-delete)
+ (let ((generation (generation-file-name profile number)))
+ (format #t (_ "deleting ~a~%") generation)
+ (delete-file generation)))
+
+ (let* ((current-number (generation-number profile))
+ (previous-number (previous-generation-number profile number))
+ (previous-generation (generation-file-name profile previous-number)))
+ (cond ((zero? number)) ; do not delete generation 0
+ ((and (= number current-number)
+ (not (file-exists? previous-generation)))
+ (link-to-empty-profile store previous-generation)
+ (switch-to-previous-generation profile)
+ (display-and-delete))
+ ((= number current-number)
+ (roll-back store profile)
+ (display-and-delete))
+ (else
+ (display-and-delete)))))
+
+(define (delete-generations store profile generations)
+ "Delete GENERATIONS from PROFILE.
+GENERATIONS is a list of generation numbers."
+ (for-each (cut delete-generation store profile <>)
+ generations))
+
+(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 (input->name+path input)
- "Convert the name/package/sub-drv tuple INPUT to a name/store-path tuple."
- (let loop ((input input))
- (match input
- ((name (? package? package))
- (loop `(,name ,package "out")))
- ((name (? package? package) sub-drv)
- `(,name ,(package-output (%store) package sub-drv)))
- (_
- input))))
-
-(define %sigint-prompt
- ;; The prompt to jump to upon SIGINT.
- (make-prompt-tag "interruptible"))
-
-(define (call-with-sigint-handler thunk handler)
- "Call THUNK and return its value. Upon SIGINT, call HANDLER with the signal
-number in the context of the continuation of the call to this function, and
-return its return value."
- (call-with-prompt %sigint-prompt
- (lambda ()
- (sigaction SIGINT
- (lambda (signum)
- (sigaction SIGINT SIG_DFL)
- (abort-to-prompt %sigint-prompt signum)))
- (dynamic-wind
- (const #t)
- thunk
- (cut sigaction SIGINT SIG_DFL)))
- (lambda (k signum)
- (handler signum))))
-
-(define-syntax-rule (waiting exp fmt rest ...)
- "Display the given message while EXP is being evaluated."
- (let* ((message (format #f fmt rest ...))
- (blank (make-string (string-length message) #\space)))
- (display message (current-error-port))
- (force-output (current-error-port))
- (call-with-sigint-handler
- (lambda ()
- (dynamic-wind
- (const #f)
- (lambda () exp)
- (lambda ()
- ;; Clear the line.
- (display #\cr (current-error-port))
- (display blank (current-error-port))
- (display #\cr (current-error-port))
- (force-output (current-error-port)))))
- (lambda (signum)
- (format (current-error-port) " interrupted by signal ~a~%" SIGINT)
- #f))))
-
-(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,
(not (string=? current-path candidate-path))))))
(#f #f)))
-(define ftp-open*
- ;; Memoizing version of `ftp-open'. The goal is to avoid initiating a new
- ;; FTP connection for each package, esp. since most of them are to the same
- ;; server. This has a noticeable impact when doing "guix upgrade -u".
- (memoize ftp-open))
-
-(define (check-package-freshness package)
- "Check whether PACKAGE has a newer version available upstream, and report
-it."
- ;; TODO: Automatically inject the upstream version when desired.
-
- (catch #t
- (lambda ()
- (when (false-if-exception (gnu-package? package))
- (let ((name (package-name package))
- (full-name (package-full-name package)))
- (match (waiting (latest-release name
- #:ftp-open ftp-open*
- #:ftp-close (const #f))
- (_ "looking for the latest release of GNU ~a...") name)
- ((latest-version . _)
- (when (version>? latest-version full-name)
- (format (current-error-port)
- (_ "~a: note: using ~a \
-but ~a is available upstream~%")
- (location->string (package-location package))
- full-name latest-version)))
- (_ #t)))))
- (lambda (key . args)
- ;; Silently ignore networking errors rather than preventing
- ;; installation.
- (case key
- ((getaddrinfo-error ftp-error) #f)
- (else (apply throw key args))))))
-
\f
;;;
;;; Search paths.
;;;
(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 (or (find-best-packages-by-name name version)
- (find-best-packages-by-name name #f))
- ((p _ ...) p)
- (_ #f)))))
-
- (define search-path-definition
- (match-lambda
- (($ <search-path-specification> variable directories separator)
- (let ((values (or (and=> (getenv variable)
- (cut string-tokenize* <> separator))
- '()))
- (directories (filter file-exists?
- (map (cut string-append profile
- "/" <>)
- directories))))
- (if (every (cut member <> values) directories)
- #f
- (format #f "export ~a=\"~a\""
- variable
- (string-join directories 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"))
-d, --delete-generations[=PATTERN]
delete generations matching PATTERN"))
(display (_ "
+ -S, --switch-generation=PATTERN
+ switch to a generation matching PATTERN"))
+ (display (_ "
-p, --profile=PROFILE use PROFILE instead of the user's default profile"))
(newline)
(display (_ "
(display (_ "
-A, --list-available[=REGEXP]
list available packages matching REGEXP"))
+ (display (_ "
+ --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 ""))
(values (alist-cons 'delete-generations (or arg "")
result)
#f)))
- (option '("search-paths") #f #f
+ (option '(#\S "switch-generation") #t #f
(lambda (opt name arg result arg-handler)
- (values (cons `(query search-paths) result)
+ (values (alist-cons 'switch-generation arg result)
#f)))
+ (option '("search-paths") #f #t
+ (lambda (opt name arg result arg-handler)
+ (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 arg
+ (values (alist-cons 'profile (canonicalize-profile arg)
(alist-delete 'profile result))
#f)))
(option '(#\n "dry-run") #f #f
(values (cons `(query list-available ,(or arg ""))
result)
#f)))
+ (option '("show") #t #t
+ (lambda (opt name arg result arg-handler)
+ (values (cons `(query show ,arg)
+ result)
+ #f)))
%standard-build-options))
(define (options->installable opts manifest)
"Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold',
return the new list of manifest entries."
- (define (deduplicate deps)
- ;; Remove duplicate entries from DEPS, a list of propagated inputs, where
- ;; each input is a name/path tuple.
- (define (same? d1 d2)
- (match d1
- ((_ p1)
- (match d2
- ((_ p2) (eq? p1 p2))
- (_ #f)))
- ((_ p1 out1)
- (match d2
- ((_ p2 out2)
- (and (string=? out1 out2)
- (eq? p1 p2)))
- (_ #f)))))
-
- (delete-duplicates deps same?))
-
- (define (package->manifest-entry p output)
- ;; Return a manifest entry for the OUTPUT of package P.
- (check-package-freshness p)
+ (define (package->manifest-entry* package output)
+ (check-package-freshness package)
;; When given a package via `-e', install the first of its
;; outputs (XXX).
- (let* ((output (or output (car (package-outputs p))))
- (path (package-output (%store) p output))
- (deps (deduplicate (package-transitive-propagated-inputs p))))
- (manifest-entry
- (name (package-name p))
- (version (package-version p))
- (output output)
- (path path)
- (dependencies (map input->name+path deps))
- (inputs (cons (list (package-name p) p output)
- deps)))))
+ (package->manifest-entry package output))
(define upgrade-regexps
(filter-map (match-lambda
(_ #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
(()
'())
((_ ...)
- (let ((newest (find-newest-available-packages)))
- (filter-map (match-lambda
- (($ <manifest-entry> name version output path _)
- (and (any (cut regexp-exec <> name)
- upgrade-regexps)
- (upgradeable? name version path)
- (let ((output (or output "out")))
- (call-with-values
- (lambda ()
- (specification->package+output name output))
- list))))
- (_ #f))
- (manifest-entries manifest))))))
+ (filter-map (match-lambda
+ (($ <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
+ (lambda ()
+ (specification->package+output name output))
+ list))))
+ (_ #f))
+ (manifest-entries manifest)))))
(define to-upgrade
(map (match-lambda
((package output)
- (package->manifest-entry package output)))
+ (package->manifest-entry* package output)))
packages-to-upgrade))
(define packages-to-install
(define to-install
(append (map (match-lambda
((package output)
- (package->manifest-entry package output)))
+ (package->manifest-entry* package output)))
packages-to-install)
(filter-map (match-lambda
(('install . (? package?))
(name name)
(version version)
(output #f)
- (path path))))
+ (item path))))
(_ #f))
opts)))
(_ #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 (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.
- (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 (guile-missing?)
- ;; Return #t if %GUILE-FOR-BUILD is not available yet.
- (let ((out (derivation->output-path (%guile-for-build))))
- (not (valid-path? (%store) out))))
+ (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
%profile-directory)
(format (current-error-port)
(_ "Please change the owner of `~a' to user ~s.~%")
- %profile-directory (or (getenv "USER") (getuid)))
+ %profile-directory (or (getenv "USER")
+ (getenv "LOGNAME")
+ (getuid)))
(rtfm))))
(define (process-actions opts)
;; Process any install/remove/upgrade action from OPTS.
(define dry-run? (assoc-ref opts 'dry-run?))
- (define verbose? (assoc-ref opts 'verbose?))
(define profile (assoc-ref opts 'profile))
- (define (same-package? entry name output)
- (match entry
- (($ <manifest-entry> entry-name _ entry-output _ ...)
- (and (equal? name entry-name)
- (equal? output entry-output)))))
-
- (define current-generation-number
- (generation-number profile))
-
- (define (display-and-delete number)
- (let ((generation (generation-file-name profile number)))
- (unless (zero? number)
- (format #t (_ "deleting ~a~%") generation)
- (delete-file generation))))
-
- (define (delete-generation number)
- (let* ((previous-number (previous-generation-number profile number))
- (previous-generation
- (generation-file-name profile previous-number)))
- (cond ((zero? number)) ; do not delete generation 0
- ((and (= number current-generation-number)
- (not (file-exists? previous-generation)))
- (link-to-empty-profile previous-generation)
- (switch-to-previous-generation profile)
- (display-and-delete number))
- ((= number current-generation-number)
- (roll-back profile)
- (display-and-delete number))
- (else
- (display-and-delete number)))))
+ (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?) (not dry-run?))
- (begin
- (roll-back profile)
- (process-actions (alist-delete 'roll-back? opts))))
+ (cond ((and (assoc-ref opts 'roll-back?)
+ (not dry-run?))
+ (roll-back (%store) profile)
+ (process-actions (alist-delete 'roll-back? opts)))
+ ((and (assoc-ref opts 'switch-generation)
+ (not dry-run?))
+ (for-each
+ (match-lambda
+ (('switch-generation . pattern)
+ (let* ((number (string->number pattern))
+ (number (and number
+ (case (string-ref pattern 0)
+ ((#\+ #\-)
+ (relative-generation profile number))
+ (else number)))))
+ (if number
+ (switch-to-generation profile number)
+ (leave (_ "cannot switch to generation '~a'~%")
+ pattern)))
+ (process-actions (alist-delete 'switch-generation opts)))
+ (_ #f))
+ opts))
((and (assoc-ref opts 'delete-generations)
(not dry-run?))
- (filter-map
+ (for-each
(match-lambda
(('delete-generations . pattern)
- (cond ((not (file-exists? profile)) ; XXX: race condition
- (leave (_ "profile '~a' does not exist~%")
- profile))
- ((string-null? pattern)
- (let ((numbers (generation-numbers profile)))
- (if (equal? numbers '(0))
- (exit 0)
- (for-each display-and-delete
- (delete current-generation-number
- numbers)))))
- ;; 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)
- (for-each delete-generation 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))
- (entries
- (append install
- (fold (lambda (package result)
- (match package
- (($ <manifest-entry> name _ out _ ...)
- (filter (negate
- (cut same-package? <>
- name out))
- result))))
- (manifest-entries
- (manifest-remove manifest remove))
- install)))
- (new (make-manifest entries)))
-
- (when (equal? profile %current-profile)
- (ensure-default-profile))
-
- (if (manifest=? new manifest)
- (format (current-error-port) (_ "nothing to be done~%"))
- (let ((prof-drv (profile-derivation (%store) new))
- (remove (manifest-matching-entries manifest remove)))
- (show-what-to-remove/install remove install dry-run?)
- (show-what-to-build (%store) (list prof-drv)
- #:use-substitutes?
- (assoc-ref opts 'substitutes?)
- #:dry-run? dry-run?)
-
- (or dry-run?
- (let* ((prof (derivation->output-path prof-drv))
- (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 ((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)))))))))))
+ (let* ((manifest (profile-manifest profile))
+ (install (options->installable opts manifest))
+ (remove (options->removable opts manifest))
+ (transaction (manifest-transaction (install install)
+ (remove remove)))
+ (new (manifest-perform-transaction
+ manifest transaction)))
+
+ (unless (and (null? install) (null? remove))
+ (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
- (leave (_ "profile '~a' does not exist~%")
- profile))
+ (raise (condition (&profile-not-found-error
+ (profile profile)))))
((string-null? pattern)
- (let ((numbers (generation-numbers profile)))
- (leave-on-EPIPE
- (if (equal? numbers '(0))
- (exit 0)
- (for-each list-generation numbers)))))
+ (for-each list-generation (profile-generations profile)))
((matching-generations pattern profile)
=>
(lambda (numbers)
(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-description regexp)))
#t))
- (('search-paths)
+ (('show requested-name)
+ (let-values (((name version)
+ (package-name->name+version requested-name)))
+ (leave-on-EPIPE
+ (for-each (cute package->recutils <> (current-output-port))
+ (find-packages-by-name name version)))
+ #t))
+
+ (('search-paths kind)
(let* ((manifest (profile-manifest profile))
(entries (manifest-entries manifest))
- (packages (map manifest-entry-name entries))
+ (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)))
- (or (process-query opts)
- (with-error-handling
+ (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)))
(set-build-options-from-command-line (%store) opts)
(parameterize ((%guile-for-build
- (package-derivation (%store)
- (if (assoc-ref opts 'bootstrap?)
- %bootstrap-guile
- guile-final))))
+ (package-derivation
+ (%store)
+ (if (assoc-ref opts 'bootstrap?)
+ %bootstrap-guile
+ (canonical-package guile-2.0)))))
(process-actions opts)))))))
HCoop / jackhill / guix / guix.git / blobdiff