ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 21:38:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

profiles: Catch and report collisions in the profile.

Browse source 
* 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.
This commit is contained in:
Ludovic Courtès 2017-06-07 09:51:55 +02:00
parent 81e3485c0d
commit a654dc4bcf
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
3 changed files with 197 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

113
guix/profiles.scm
View file

@ -35,6 +35,8 @@ (define-module (guix profiles)
#: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 @@ (define-module (guix profiles)
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 @@ (define-module (guix profiles)
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-error &error
(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 @@ (define-record-type <manifest>
;; 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 @@ (define (profile-manifest profile)
(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 @@ (define* (profile-derivation manifest
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
View file

@ -476,6 +476,33 @@ (define (port-filename* port)
(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)))

66
tests/profiles.scm
View file

@ -35,6 +35,7 @@ (define-module (test-profiles)
#: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 @@ (define (entry->sexp entry)
(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