From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:53167) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1dIXE7-0000Op-4S for guix-patches@gnu.org; Wed, 07 Jun 2017 05:26:08 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1dIXE3-0001n3-ID for guix-patches@gnu.org; Wed, 07 Jun 2017 05:26:07 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:57653) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1dIXE3-0001mq-De for guix-patches@gnu.org; Wed, 07 Jun 2017 05:26:03 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1dIXE3-0002a9-7R for guix-patches@gnu.org; Wed, 07 Jun 2017 05:26:03 -0400 Subject: bug#27271: [PATCH 4/4] profiles: Catch and report collisions in the profile. Resent-Message-ID: From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Wed, 7 Jun 2017 11:25:06 +0200 Message-Id: <20170607092506.20844-4-ludo@gnu.org> In-Reply-To: <20170607092506.20844-1-ludo@gnu.org> References: <20170607092506.20844-1-ludo@gnu.org> List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 27271@debbugs.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) ; + (conflict profile-collision-error-conflict)) ; + (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