M guix/profiles.scm => guix/profiles.scm +104 -9
@@ 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)
M guix/ui.scm => guix/ui.scm +27 -0
@@ 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)))
M tests/profiles.scm => tests/profiles.scm +66 -0
@@ 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