bug#27271: [PATCH 4/4] profiles: Catch and report collisions in the profile.

[Ludovic Courtès]

* 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 address@hidden")
+                                   (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: address@hidden:~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: address@hidden:~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