From 487cbb0164c715e722b622fa800fa0b217fa132c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 7 Feb 2019 14:54:43 +0100 Subject: 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. --- guix/profiles.scm | 34 ++++++++++++++++++++++++---------- guix/ui.scm | 8 ++++++++ tests/guix-package.sh | 7 ++++++- tests/profiles.scm | 17 +++++++++++------ 4 files changed, 49 insertions(+), 17 deletions(-) diff --git a/guix/profiles.scm b/guix/profiles.scm index efe5ecb9dc..6564526aee 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -63,6 +63,10 @@ &missing-generation-error missing-generation-error? missing-generation-error-generation + &unmatched-pattern-error + unmatched-pattern-error? + unmatched-pattern-error-pattern + unmatched-pattern-error-manifest manifest make-manifest manifest? @@ -156,6 +160,11 @@ (entry profile-collision-error-entry) ; (conflict profile-collision-error-conflict)) ; +(define-condition-type &unmatched-pattern-error &error + unmatched-pattern-error? + (pattern unmatched-pattern-error-pattern) ; + (manifest unmatched-pattern-error-manifest)) ; + (define-condition-type &missing-generation-error &profile-error missing-generation-error? (generation missing-generation-error-generation)) @@ -559,16 +568,21 @@ no match.." (->bool (manifest-lookup manifest pattern))) (define (manifest-matching-entries manifest patterns) - "Return all the entries of MANIFEST that match one of the PATTERNS." - (define predicates - (map entry-predicate patterns)) - - (define (matches? entry) - (any (lambda (pred) - (pred entry)) - predicates)) - - (filter matches? (manifest-entries manifest))) + "Return all the entries of MANIFEST that match one of the PATTERNS. Raise +an '&unmatched-pattern-error' if none of the entries of MANIFEST matches one +of PATTERNS." + (fold-right (lambda (pattern matches) + (match (filter (entry-predicate pattern) + (manifest-entries manifest)) + (() + (raise (condition + (&unmatched-pattern-error + (pattern pattern) + (manifest manifest))))) + (lst + (append lst matches)))) + '() + patterns)) (define (manifest-search-paths manifest) "Return the list of search path specifications that apply to MANIFEST, diff --git a/guix/ui.scm b/guix/ui.scm index 9eab4ba3f7..f0465519b6 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -643,6 +643,14 @@ or remove one of them from the profile.") (leave (G_ "generation ~a of profile '~a' does not exist~%") (missing-generation-error-generation 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) (let ((entry (profile-collision-error-entry c)) (conflict (profile-collision-error-conflict c))) diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 7eeb4304d1..0d60481895 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès # Copyright © 2013 Nikita Karetnikov # # 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"; 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. guix package -p "$profile" -A 'gui.*e' | grep guile diff --git a/tests/profiles.scm b/tests/profiles.scm index 9a05030aff..eef93e24cf 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -93,10 +93,7 @@ (test-assert "manifest-matching-entries" (let* ((e (list guile-2.0.9 guile-2.0.9:debug)) (m (manifest e))) - (and (null? (manifest-matching-entries m - (list (manifest-pattern - (name "python"))))) - (equal? e + (and (equal? e (manifest-matching-entries m (list (manifest-pattern (name "guile") @@ -107,6 +104,15 @@ (name "guile") (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" (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug))) (m1 (manifest-remove m0 @@ -165,8 +171,7 @@ (test-assert "manifest-transaction-effects" (let* ((m0 (manifest (list guile-1.8.8))) (t (manifest-transaction - (install (list guile-2.0.9 glibc)) - (remove (list (manifest-pattern (name "coreutils"))))))) + (install (list guile-2.0.9 glibc))))) (let-values (((remove install upgrade downgrade) (manifest-transaction-effects m0 t))) (and (null? remove) (null? downgrade) -- cgit v1.2.3