profiles: Raise an error for unmatched patterns.

Previously, "guix package -r something-not-installed" would silently
complete.  Now an error is raised.

* guix/profiles.scm (&unmatched-pattern-error): New condition type.
(manifest-matching-entries): Rewrite to raise an error when one of
PATTERNS is not matched.
* guix/ui.scm (call-with-error-handling): Handle 'unmatched-pattern-error?'.
* tests/guix-package.sh: Add test.
* tests/profiles.scm ("manifest-matching-entries"): Don't try to remove
unmatched pattern.
("manifest-matching-entries, no match"): New test.
("manifest-transaction-effects"): Remove 'remove' field.
This commit is contained in:
Ludovic Courtès 2019-02-07 14:54:43 +01:00 committed by Ludovic Courtès
parent 89ea6252b6
commit 487cbb0164
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
4 changed files with 49 additions and 17 deletions

View file

@ -63,6 +63,10 @@ (define-module (guix profiles)
&missing-generation-error &missing-generation-error
missing-generation-error? missing-generation-error?
missing-generation-error-generation missing-generation-error-generation
&unmatched-pattern-error
unmatched-pattern-error?
unmatched-pattern-error-pattern
unmatched-pattern-error-manifest
manifest make-manifest manifest make-manifest
manifest? manifest?
@ -156,6 +160,11 @@ (define-condition-type &profile-collision-error &error
(entry profile-collision-error-entry) ;<manifest-entry> (entry profile-collision-error-entry) ;<manifest-entry>
(conflict profile-collision-error-conflict)) ;<manifest-entry> (conflict profile-collision-error-conflict)) ;<manifest-entry>
(define-condition-type &unmatched-pattern-error &error
unmatched-pattern-error?
(pattern unmatched-pattern-error-pattern) ;<manifest-pattern>
(manifest unmatched-pattern-error-manifest)) ;<manifest>
(define-condition-type &missing-generation-error &profile-error (define-condition-type &missing-generation-error &profile-error
missing-generation-error? missing-generation-error?
(generation missing-generation-error-generation)) (generation missing-generation-error-generation))
@ -559,16 +568,21 @@ (define (manifest-installed? manifest pattern)
(->bool (manifest-lookup manifest pattern))) (->bool (manifest-lookup manifest pattern)))
(define (manifest-matching-entries manifest patterns) (define (manifest-matching-entries manifest patterns)
"Return all the entries of MANIFEST that match one of the PATTERNS." "Return all the entries of MANIFEST that match one of the PATTERNS. Raise
(define predicates an '&unmatched-pattern-error' if none of the entries of MANIFEST matches one
(map entry-predicate patterns)) of PATTERNS."
(fold-right (lambda (pattern matches)
(define (matches? entry) (match (filter (entry-predicate pattern)
(any (lambda (pred) (manifest-entries manifest))
(pred entry)) (()
predicates)) (raise (condition
(&unmatched-pattern-error
(filter matches? (manifest-entries manifest))) (pattern pattern)
(manifest manifest)))))
(lst
(append lst matches))))
'()
patterns))
(define (manifest-search-paths manifest) (define (manifest-search-paths manifest)
"Return the list of search path specifications that apply to MANIFEST, "Return the list of search path specifications that apply to MANIFEST,

View file

@ -643,6 +643,14 @@ (define (port-filename* port)
(leave (G_ "generation ~a of profile '~a' does not exist~%") (leave (G_ "generation ~a of profile '~a' does not exist~%")
(missing-generation-error-generation c) (missing-generation-error-generation c)
(profile-error-profile c))) (profile-error-profile c)))
((unmatched-pattern-error? c)
(let ((pattern (unmatched-pattern-error-pattern c)))
(leave (G_ "package '~a~@[@~a~]~@[:~a~]' not found in profile~%")
(manifest-pattern-name pattern)
(manifest-pattern-version pattern)
(match (manifest-pattern-output pattern)
("out" #f)
(output output)))))
((profile-collision-error? c) ((profile-collision-error? c)
(let ((entry (profile-collision-error-entry c)) (let ((entry (profile-collision-error-entry c))
(conflict (profile-collision-error-conflict c))) (conflict (profile-collision-error-conflict c)))

View file

@ -1,5 +1,5 @@
# GNU Guix --- Functional package management for GNU # 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 Nikita Karetnikov <nikita@karetnikov.org>
# #
# This file is part of GNU Guix. # This file is part of GNU Guix.
@ -97,6 +97,11 @@ then false; else true; fi
if guix package --bootstrap -i "guile-bootstrap:does-not-exist" -p "$profile"; if guix package --bootstrap -i "guile-bootstrap:does-not-exist" -p "$profile";
then false; else true; fi then false; else true; fi
# Make sure we get an error when trying to remove something that's not
# installed.
if guix package --bootstrap -r something-not-installed -p "$profile";
then false; else true; fi
# Check whether `--list-available' returns something sensible. # Check whether `--list-available' returns something sensible.
guix package -p "$profile" -A 'gui.*e' | grep guile guix package -p "$profile" -A 'gui.*e' | grep guile

View file

@ -93,10 +93,7 @@ (define glibc
(test-assert "manifest-matching-entries" (test-assert "manifest-matching-entries"
(let* ((e (list guile-2.0.9 guile-2.0.9:debug)) (let* ((e (list guile-2.0.9 guile-2.0.9:debug))
(m (manifest e))) (m (manifest e)))
(and (null? (manifest-matching-entries m (and (equal? e
(list (manifest-pattern
(name "python")))))
(equal? e
(manifest-matching-entries m (manifest-matching-entries m
(list (manifest-pattern (list (manifest-pattern
(name "guile") (name "guile")
@ -107,6 +104,15 @@ (define glibc
(name "guile") (name "guile")
(version "2.0.9")))))))) (version "2.0.9"))))))))
(test-assert "manifest-matching-entries, no match"
(let ((m (manifest (list guile-2.0.9)))
(p (manifest-pattern (name "python"))))
(guard (c ((unmatched-pattern-error? c)
(and (eq? p (unmatched-pattern-error-pattern c))
(eq? m (unmatched-pattern-error-manifest c)))))
(manifest-matching-entries m (list p))
#f)))
(test-assert "manifest-remove" (test-assert "manifest-remove"
(let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug))) (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
(m1 (manifest-remove m0 (m1 (manifest-remove m0
@ -165,8 +171,7 @@ (define glibc
(test-assert "manifest-transaction-effects" (test-assert "manifest-transaction-effects"
(let* ((m0 (manifest (list guile-1.8.8))) (let* ((m0 (manifest (list guile-1.8.8)))
(t (manifest-transaction (t (manifest-transaction
(install (list guile-2.0.9 glibc)) (install (list guile-2.0.9 glibc)))))
(remove (list (manifest-pattern (name "coreutils")))))))
(let-values (((remove install upgrade downgrade) (let-values (((remove install upgrade downgrade)
(manifest-transaction-effects m0 t))) (manifest-transaction-effects m0 t)))
(and (null? remove) (null? downgrade) (and (null? remove) (null? downgrade)