05/06: profiles: Catch and report collisions in the profile.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit a654dc4bcf7c8e205bdefa1a1d5f23444dd22778
Author: Ludovic Courtès <address@hidden>
Date:   Wed Jun 7 09:51:55 2017 +0200

    profiles: Catch and report collisions in the profile.
    
    * guix/profiles.scm (&profile-collision-error): New error condition.
    (manifest-transitive-entries, 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", "collision of propagated inputs")
    ("no collision"): New tests.
---
 guix/profiles.scm  | 113 ++++++++++++++++++++++++++++++++++++++++++++++++-----
 guix/ui.scm        |  27 +++++++++++++
 tests/profiles.scm |  66 +++++++++++++++++++++++++++++++
 3 files changed, 197 insertions(+), 9 deletions(-)

diff --git a/guix/profiles.scm b/guix/profiles.scm
index c85d7ef..9858ec7 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -35,6 +35,8 @@
   #:use-module (guix gexp)
   #:use-module (guix monads)
   #:use-module (guix store)
+  #:use-module (guix sets)
+  #:use-module (ice-9 vlist)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 ftw)
@@ -51,6 +53,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
@@ -58,6 +64,7 @@
             manifest make-manifest
             manifest?
             manifest-entries
+            manifest-transitive-entries
 
             <manifest-entry>              ; FIXME: eventually make it internal
             manifest-entry
@@ -130,6 +137,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))
@@ -147,6 +159,23 @@
 ;; Convenient alias, to avoid name clashes.
 (define make-manifest manifest)
 
+(define (manifest-transitive-entries manifest)
+  "Return the entries of MANIFEST along with their propagated inputs,
+recursively."
+  (let loop ((entries (manifest-entries manifest))
+             (result  '())
+             (visited (set)))                     ;compare with 'equal?'
+    (match entries
+      (()
+       (reverse result))
+      ((head . tail)
+       (if (set-contains? visited head)
+           (loop tail result visited)
+           (loop (append (manifest-entry-dependencies head)
+                         tail)
+                 (cons head result)
+                 (set-insert head visited)))))))
+
 (define-record-type* <manifest-entry> manifest-entry
   make-manifest-entry
   manifest-entry?
@@ -178,6 +207,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-transitive-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 +1209,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 889c9d0..c141880 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 94759c0..f731807 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,71 @@
         (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-equal "collision of propagated inputs"
+  '(("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
+                                     `(("guile" ,%bootstrap-guile)))))
+                           (p2 -> (dummy-package "p2"
+                                    (propagated-inputs
+                                     `(("guile" ,p0)))))
+                           (manifest -> (packages->manifest (list p1 p2)))
+                           (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