;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2016 Roel Janssen <roel@gnu.org>
;;; Copyright © 2016 Benz Schenk <benz.schenk@uzh.ch>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
(define-module (guix scripts package)
#:use-module (guix ui)
+ #:use-module ((guix status) #:select (with-status-verbosity))
#:use-module (guix store)
#:use-module (guix grafts)
#:use-module (guix derivations)
#:use-module (guix config)
#:use-module (guix scripts)
#:use-module (guix scripts build)
+ #:autoload (guix describe) (package-provenance)
#:use-module ((guix build utils)
#:select (directory-exists? mkdir-p))
#:use-module (ice-9 format)
#:autoload (gnu packages bootstrap) (%bootstrap-guile)
#:export (build-and-use-profile
delete-generations
+ delete-matching-generations
display-search-paths
guix-package))
(define (ensure-default-profile)
"Ensure the default profile symlink and directory exist and are writable."
-
- (define (rtfm)
- (format (current-error-port)
- (G_ "Try \"info '(guix) Invoking guix package'\" for \
-more information.~%"))
- (exit 1))
+ (ensure-profile-directory)
;; Create ~/.guix-profile if it doesn't exist yet.
(when (and %user-profile-directory
%current-profile
(not (false-if-exception
(lstat %user-profile-directory))))
- (symlink %current-profile %user-profile-directory))
-
- (let ((s (stat %profile-directory #f)))
- ;; Attempt to create /…/profiles/per-user/$USER if needed.
- (unless (and s (eq? 'directory (stat:type s)))
- (catch 'system-error
- (lambda ()
- (mkdir-p %profile-directory))
- (lambda args
- ;; Often, we cannot create %PROFILE-DIRECTORY because its
- ;; parent directory is root-owned and we're running
- ;; unprivileged.
- (format (current-error-port)
- (G_ "error: while creating directory `~a': ~a~%")
- %profile-directory
- (strerror (system-error-errno args)))
- (format (current-error-port)
- (G_ "Please create the `~a' directory, with you as the owner.~%")
- %profile-directory)
- (rtfm))))
-
- ;; Bail out if it's not owned by the user.
- (unless (or (not s) (= (stat:uid s) (getuid)))
- (format (current-error-port)
- (G_ "error: directory `~a' is not owned by you~%")
- %profile-directory)
- (format (current-error-port)
- (G_ "Please change the owner of `~a' to user ~s.~%")
- %profile-directory (or (getenv "USER")
- (getenv "LOGNAME")
- (getuid)))
- (rtfm))))
+ (symlink %current-profile %user-profile-directory)))
(define (delete-generations store profile generations)
"Delete GENERATIONS from PROFILE.
(define* (build-and-use-profile store profile manifest
#:key
+ (hooks %default-profile-hooks)
allow-collisions?
bootstrap? use-substitutes?
dry-run?)
"Build a new generation of PROFILE, a file name, using the packages
specified in MANIFEST, a manifest object. When ALLOW-COLLISIONS? is true,
-do not treat collisions in MANIFEST as an error."
+do not treat collisions in MANIFEST as an error. HOOKS is a list of \"profile
+hooks\" run when building the profile."
(when (equal? profile %current-profile)
(ensure-default-profile))
(let* ((prof-drv (run-with-store store
(profile-derivation manifest
#:allow-collisions? allow-collisions?
- #:hooks (if bootstrap?
- '()
- %default-profile-hooks)
+ #:hooks (if bootstrap? '() hooks)
#:locales? (not bootstrap?))))
(prof (derivation->output-path prof-drv)))
(show-what-to-build store (list prof-drv)
count)
count)
(display-search-paths entries (list profile)
- #:kind 'prefix))))))))
+ #:kind 'prefix)))
+
+ (warn-about-disk-space profile))))))
\f
;;;
(info (G_ "package '~a' has been superseded by '~a'~%")
(manifest-entry-name old) (package-name new))
(manifest-transaction-install-entry
- (package->manifest-entry new (manifest-entry-output old))
+ (package->manifest-entry* new (manifest-entry-output old))
(manifest-transaction-remove-pattern
(manifest-pattern
(name (manifest-entry-name old))
('dismiss
transaction)
(($ <manifest-entry> name version output (? string? path))
- (match (vhash-assoc name (find-newest-available-packages))
- ((_ candidate-version pkg . rest)
- (match (package-superseded pkg)
- ((? package? new)
- (supersede entry new))
- (#f
- (case (version-compare candidate-version version)
- ((>)
- (manifest-transaction-install-entry
- (package->manifest-entry pkg output)
- transaction))
- ((<)
- transaction)
- ((=)
- (let ((candidate-path (derivation->output-path
- (package-derivation (%store) pkg))))
- ;; XXX: When there are propagated inputs, assume we need to
- ;; upgrade the whole entry.
- (if (and (string=? path candidate-path)
- (null? (package-propagated-inputs pkg)))
- transaction
- (manifest-transaction-install-entry
- (package->manifest-entry pkg output)
- transaction))))))))
- (#f
+ (match (find-best-packages-by-name name #f)
+ ((pkg . rest)
+ (let ((candidate-version (package-version pkg)))
+ (match (package-superseded pkg)
+ ((? package? new)
+ (supersede entry new))
+ (#f
+ (case (version-compare candidate-version version)
+ ((>)
+ (manifest-transaction-install-entry
+ (package->manifest-entry* pkg output)
+ transaction))
+ ((<)
+ transaction)
+ ((=)
+ (let ((candidate-path (derivation->output-path
+ (package-derivation (%store) pkg))))
+ ;; XXX: When there are propagated inputs, assume we need to
+ ;; upgrade the whole entry.
+ (if (and (string=? path candidate-path)
+ (null? (package-propagated-inputs pkg)))
+ transaction
+ (manifest-transaction-install-entry
+ (package->manifest-entry* pkg output)
+ transaction)))))))))
+ (()
(warning (G_ "package '~a' no longer exists~%") name)
transaction)))))
(define %default-options
;; Alist of default option values.
- `((verbosity . 0)
+ `((verbosity . 1)
+ (debug . 0)
(graft? . #t)
(substitutes? . #t)
- (build-hook? . #t)))
+ (build-hook? . #t)
+ (print-build-trace? . #t)
+ (print-extended-build-trace? . #t)
+ (multiplexed-build-output? . #t)))
(define (show-help)
(display (G_ "Usage: guix package [OPTION]...
(display (G_ "
--bootstrap use the bootstrap Guile to build the profile"))
(display (G_ "
- --verbose produce verbose output"))
+ -v, --verbosity=LEVEL use the given verbosity LEVEL"))
(newline)
(display (G_ "
-s, --search=REGEXP search in synopsis and description using REGEXP"))
(values (alist-cons 'dry-run? #t
(alist-cons 'graft? #f result))
#f)))
+ (option '(#\v "verbosity") #t #f
+ (lambda (opt name arg result arg-handler)
+ (let ((level (string->number* arg)))
+ (values (alist-cons 'verbosity level
+ (alist-delete 'verbosity result))
+ #f))))
(option '("bootstrap") #f #f
(lambda (opt name arg result arg-handler)
(values (alist-cons 'bootstrap? #t result)
#f)))
- (option '("verbose") #f #f
+ (option '("verbose") #f #f ;deprecated
(lambda (opt name arg result arg-handler)
- (values (alist-cons 'verbose? #t result)
+ (values (alist-cons 'verbosity 2
+ (alist-delete 'verbosity
+ result))
#f)))
(option '("allow-collisions") #f #f
(lambda (opt name arg result arg-handler)
(define upgrade-regexps
(filter-map (match-lambda
(('upgrade . regexp)
- (make-regexp* (or regexp "")))
+ (make-regexp* (or regexp "") regexp/icase))
(_ #f))
opts))
(define do-not-upgrade-regexps
(filter-map (match-lambda
(('do-not-upgrade . regexp)
- (make-regexp* regexp))
+ (make-regexp* regexp regexp/icase))
(_ #f))
opts))
(output "out") ;XXX: wild guess
(item item))))
+(define (package->manifest-entry* package output)
+ "Like 'package->manifest-entry', but attach PACKAGE provenance meta-data to
+the resulting manifest entry."
+ (define (provenance-properties package)
+ (match (package-provenance package)
+ (#f '())
+ (sexp `((provenance ,@sexp)))))
+
+ (package->manifest-entry package output
+ #:properties (provenance-properties package)))
+
+
(define (options->installable opts manifest transaction)
"Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold',
return an variant of TRANSACTION that accounts for the specified installations
(options->upgrade-predicate opts))
(define upgraded
- (fold-right (lambda (entry transaction)
- (if (upgrade? (manifest-entry-name entry))
- (transaction-upgrade-entry entry transaction)
- transaction))
- transaction
- (manifest-entries manifest)))
+ (fold (lambda (entry transaction)
+ (if (upgrade? (manifest-entry-name entry))
+ (transaction-upgrade-entry entry transaction)
+ transaction))
+ transaction
+ (manifest-entries manifest)))
(define to-install
(filter-map (match-lambda
(('install . (? package? p))
;; When given a package via `-e', install the first of its
;; outputs (XXX).
- (package->manifest-entry p "out"))
+ (package->manifest-entry* p "out"))
(('install . (? string? spec))
(if (store-path? spec)
(store-item->manifest-entry spec)
(let-values (((package output)
(specification->package+output spec)))
- (package->manifest-entry package output))))
+ (package->manifest-entry* package output))))
(_ #f))
opts))
#t)
(('list-installed regexp)
- (let* ((regexp (and regexp (make-regexp* regexp)))
+ (let* ((regexp (and regexp (make-regexp* regexp regexp/icase)))
(manifest (profile-manifest profile))
(installed (manifest-entries manifest)))
(leave-on-EPIPE
#t))
(('list-available regexp)
- (let* ((regexp (and regexp (make-regexp* regexp)))
- (available (fold-packages
- (lambda (p r)
- (let ((n (package-name p)))
- (if (and (supported-package? p)
- (not (package-superseded p)))
- (if regexp
- (if (regexp-exec regexp n)
- (cons p r)
- r)
- (cons p r))
- r)))
+ (let* ((regexp (and regexp (make-regexp* regexp regexp/icase)))
+ (available (fold-available-packages
+ (lambda* (name version result
+ #:key outputs location
+ supported? deprecated?
+ #:allow-other-keys)
+ (if (and supported? (not deprecated?))
+ (if regexp
+ (if (regexp-exec regexp name)
+ (cons `(,name ,version
+ ,outputs ,location)
+ result)
+ result)
+ (cons `(,name ,version
+ ,outputs ,location)
+ result))
+ result))
'())))
(leave-on-EPIPE
- (for-each (lambda (p)
- (format #t "~a\t~a\t~a\t~a~%"
- (package-name p)
- (package-version p)
- (string-join (package-outputs p) ",")
- (location->string (package-location p))))
+ (for-each (match-lambda
+ ((name version outputs location)
+ (format #t "~a\t~a\t~a\t~a~%"
+ name version
+ (string-join outputs ",")
+ (location->string location))))
(sort available
- (lambda (p1 p2)
- (string<? (package-name p1)
- (package-name p2))))))
+ (match-lambda*
+ (((name1 . _) (name2 . _))
+ (string<? name1 name2))))))
#t))
(('search _)
(('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)))
+ (match (find-packages-by-name name version)
+ (()
+ (leave (G_ "~a~@[@~a~]: package not found~%") name version))
+ (packages
+ (leave-on-EPIPE
+ (for-each (cute package->recutils <> (current-output-port))
+ packages))))
#t))
(('search-paths kind)
(arg-handler arg result)
(leave (G_ "~A: extraneous argument~%") arg)))
- (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))
- (%graft? (assoc-ref opts 'graft?)))
- (set-build-options-from-command-line (%store) opts)
+ (define 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))
+ (%graft? (assoc-ref opts 'graft?)))
+ (with-status-verbosity (assoc-ref opts 'verbosity)
+ (set-build-options-from-command-line (%store) opts)
(parameterize ((%guile-for-build
(package-derivation
(%store)
HCoop / jackhill / guix / guix.git / blobdiff