From: "Ludovic Courtès" <ludo@gnu.org>
To: 27271@debbugs.gnu.org
Subject: bug#27271: [PATCH 4/4] profiles: Catch and report collisions in the profile.
Date: Wed, 7 Jun 2017 11:25:06 +0200 [thread overview]
Message-ID: <20170607092506.20844-4-ludo@gnu.org> (raw)
In-Reply-To: <20170607092506.20844-1-ludo@gnu.org>
* guix/profiles.scm (&profile-collision-error): New error condition.
(manifest-entry-lookup, lower-manifest-entry, check-for-collisions): New
procedures.
(profile-derivation): Add call to 'check-for-collisions'.
* guix/ui.scm (call-with-error-handling): Handle '&profile-collision-error'.
* tests/profiles.scm ("collision", "no collision"): New tests.
---
guix/profiles.scm | 94 ++++++++++++++++++++++++++++++++++++++++++++++++------
guix/ui.scm | 27 ++++++++++++++++
tests/profiles.scm | 41 ++++++++++++++++++++++++
3 files changed, 153 insertions(+), 9 deletions(-)
diff --git a/guix/profiles.scm b/guix/profiles.scm
index c85d7ef5c..980229ca7 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -35,6 +35,7 @@
#:use-module (guix gexp)
#:use-module (guix monads)
#:use-module (guix store)
+ #:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 ftw)
@@ -51,6 +52,10 @@
profile-error-profile
&profile-not-found-error
profile-not-found-error?
+ &profile-collistion-error
+ profile-collision-error?
+ profile-collision-error-entry
+ profile-collision-error-conflict
&missing-generation-error
missing-generation-error?
missing-generation-error-generation
@@ -130,6 +135,11 @@
(define-condition-type &profile-not-found-error &profile-error
profile-not-found-error?)
+(define-condition-type &profile-collision-error &error
+ profile-collision-error?
+ (entry profile-collision-error-entry) ;<manifest-entry>
+ (conflict profile-collision-error-conflict)) ;<manifest-entry>
+
(define-condition-type &missing-generation-error &profile-error
missing-generation-error?
(generation missing-generation-error-generation))
@@ -178,6 +188,70 @@
(call-with-input-file file read-manifest)
(manifest '()))))
+(define (manifest-entry-lookup manifest)
+ "Return a lookup procedure for the entries of MANIFEST. The lookup
+procedure takes two arguments: the entry name and output."
+ (define mapping
+ (let loop ((entries (manifest-entries manifest))
+ (mapping vlist-null))
+ (fold (lambda (entry result)
+ (vhash-cons (cons (manifest-entry-name entry)
+ (manifest-entry-output entry))
+ entry
+ (loop (manifest-entry-dependencies entry)
+ result)))
+ mapping
+ entries)))
+
+ (lambda (name output)
+ (match (vhash-assoc (cons name output) mapping)
+ ((_ . entry) entry)
+ (#f #f))))
+
+(define* (lower-manifest-entry entry system #:key target)
+ "Lower ENTRY for SYSTEM and TARGET such that its 'item' field is a store
+file name."
+ (let ((item (manifest-entry-item entry)))
+ (if (string? item)
+ (with-monad %store-monad
+ (return entry))
+ (mlet %store-monad ((drv (lower-object item system
+ #:target target))
+ (output -> (manifest-entry-output entry)))
+ (return (manifest-entry
+ (inherit entry)
+ (item (derivation->output-path drv output))))))))
+
+(define* (check-for-collisions manifest system #:key target)
+ "Check whether the entries of MANIFEST conflict with one another; raise a
+'&profile-collision-error' when a conflict is encountered."
+ (define lookup
+ (manifest-entry-lookup manifest))
+
+ (with-monad %store-monad
+ (foldm %store-monad
+ (lambda (entry result)
+ (match (lookup (manifest-entry-name entry)
+ (manifest-entry-output entry))
+ ((? manifest-entry? second) ;potential conflict
+ (mlet %store-monad ((first (lower-manifest-entry entry system
+ #:target
+ target))
+ (second (lower-manifest-entry second system
+ #:target
+ target)))
+ (if (string=? (manifest-entry-item first)
+ (manifest-entry-item second))
+ (return result)
+ (raise (condition
+ (&profile-collision-error
+ (entry first)
+ (conflict second)))))))
+ (#f ;no conflict
+ (return result))))
+ #t
+ (manifest-entries manifest))))
+
(define* (package->manifest-entry package #:optional (output "out")
#:key (parent (delay #f)))
"Return a manifest entry for the OUTPUT of package PACKAGE."
@@ -1116,15 +1190,17 @@ a dependency on the 'glibc-utf8-locales' package.
When TARGET is true, it must be a GNU triplet, and the packages in MANIFEST
are cross-built for TARGET."
- (mlet %store-monad ((system (if system
- (return system)
- (current-system)))
- (extras (if (null? (manifest-entries manifest))
- (return '())
- (sequence %store-monad
- (map (lambda (hook)
- (hook manifest))
- hooks)))))
+ (mlet* %store-monad ((system (if system
+ (return system)
+ (current-system)))
+ (ok? (check-for-collisions manifest system
+ #:target target))
+ (extras (if (null? (manifest-entries manifest))
+ (return '())
+ (sequence %store-monad
+ (map (lambda (hook)
+ (hook manifest))
+ hooks)))))
(define inputs
(append (filter-map (lambda (drv)
(and (derivation? drv)
diff --git a/guix/ui.scm b/guix/ui.scm
index 5060fd6dc..82be0311d 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -476,6 +476,33 @@ interpreted."
(leave (G_ "generation ~a of profile '~a' does not exist~%")
(missing-generation-error-generation c)
(profile-error-profile c)))
+ ((profile-collision-error? c)
+ (let ((entry (profile-collision-error-entry c))
+ (conflict (profile-collision-error-conflict c)))
+ (define (report-parent-entries entry)
+ (let ((parent (force (manifest-entry-parent entry))))
+ (when (manifest-entry? parent)
+ (report-error (G_ " ... propagated from ~a@~a~%")
+ (manifest-entry-name parent)
+ (manifest-entry-version parent))
+ (report-parent-entries parent))))
+
+ (report-error (G_ "profile contains conflicting entries for ~a:~a~%")
+ (manifest-entry-name entry)
+ (manifest-entry-output entry))
+ (report-error (G_ " first entry: ~a@~a:~a ~a~%")
+ (manifest-entry-name entry)
+ (manifest-entry-version entry)
+ (manifest-entry-output entry)
+ (manifest-entry-item entry))
+ (report-parent-entries entry)
+ (report-error (G_ " second entry: ~a@~a:~a ~a~%")
+ (manifest-entry-name conflict)
+ (manifest-entry-version conflict)
+ (manifest-entry-output conflict)
+ (manifest-entry-item conflict))
+ (report-parent-entries conflict)
+ (exit 1)))
((nar-error? c)
(let ((file (nar-error-file c))
(port (nar-error-port c)))
diff --git a/tests/profiles.scm b/tests/profiles.scm
index 94759c05e..ac9e2181d 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -35,6 +35,7 @@
#:use-module (rnrs io ports)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-34)
#:use-module (srfi srfi-64))
;; Test the (guix profiles) module.
@@ -334,6 +335,46 @@
(return (equal? (map entry->sexp (manifest-entries manifest))
(map entry->sexp (manifest-entries manifest2))))))))
+(test-equal "collision"
+ '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42"))
+ (guard (c ((profile-collision-error? c)
+ (let ((entry1 (profile-collision-error-entry c))
+ (entry2 (profile-collision-error-conflict c)))
+ (list (list (manifest-entry-name entry1)
+ (manifest-entry-version entry1))
+ (list (manifest-entry-name entry2)
+ (manifest-entry-version entry2))))))
+ (run-with-store %store
+ (mlet* %store-monad ((p0 -> (package
+ (inherit %bootstrap-guile)
+ (version "42")))
+ (p1 -> (dummy-package "p1"
+ (propagated-inputs `(("p0" ,p0)))))
+ (manifest -> (packages->manifest
+ (list %bootstrap-guile p1)))
+ (drv (profile-derivation manifest
+ #:hooks '()
+ #:locales? #f)))
+ (return #f)))))
+
+(test-assertm "no collision"
+ ;; Here we have an entry that is "lowered" (its 'item' field is a store file
+ ;; name) and another entry (its 'item' field is a package) that is
+ ;; equivalent.
+ (mlet* %store-monad ((p -> (dummy-package "p"
+ (propagated-inputs
+ `(("guile" ,%bootstrap-guile)))))
+ (guile (package->derivation %bootstrap-guile))
+ (entry -> (manifest-entry
+ (inherit (package->manifest-entry
+ %bootstrap-guile))
+ (item (derivation->output-path guile))))
+ (manifest -> (manifest
+ (list entry
+ (package->manifest-entry p))))
+ (drv (profile-derivation manifest)))
+ (return (->bool drv))))
+
(test-assertm "etc/profile"
;; Make sure we get an 'etc/profile' file that at least defines $PATH.
(mlet* %store-monad
--
2.13.0
next prev parent reply other threads:[~2017-06-07 9:26 UTC|newest]
Thread overview: 14+ messages / expand[flat|nested] mbox.gz Atom feed top
2017-06-07 9:22 bug#27271: [PATCH 0/4] Catch collisions at profile creation time Ludovic Courtès
2017-06-07 9:25 ` bug#27271: [PATCH 1/4] profiles: Represent propagated inputs as manifest entries Ludovic Courtès
2017-06-07 9:25 ` bug#27271: [PATCH 2/4] profiles: Manifest entries keep a reference to their parent entry Ludovic Courtès
2017-06-07 9:25 ` bug#27271: [PATCH 3/4] guix package: Always upgrade packages that have propagated inputs Ludovic Courtès
2017-06-07 9:25 ` Ludovic Courtès [this message]
2017-06-09 1:42 ` bug#27271: [PATCH 0/4] Catch collisions at profile creation time Ricardo Wurmus
2017-06-09 9:41 ` Ludovic Courtès
2017-06-09 20:32 ` Marius Bakke
2017-06-10 13:39 ` bug#27271: Avoiding ‘propagated-inputs’ for Python dependencies Ludovic Courtès
2017-06-17 8:40 ` [bug#27271] " Hartmut Goebel
2017-06-17 9:00 ` Hartmut Goebel
2017-06-17 9:28 ` [bug#27271] [PATCH 0/4] Catch collisions at profile creation time Ricardo Wurmus
2017-06-17 12:30 ` Ludovic Courtès
2017-06-21 9:07 ` bug#27271: " Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20170607092506.20844-4-ludo@gnu.org \
--to=ludo@gnu.org \
--cc=27271@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.