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.
master
Ludovic Courtès
parent
81e3485c0d
commit
a654dc4bcf
|
|
@ -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)
|
||||
|
|
|
|||
27
guix/ui.scm
27
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)))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Reference in New Issue