kreyren/guix-kreyren
1
0
Fork 0
Code Issues 1 Pull Requests 1 Releases Activity

grafts: 'graft-derivation' does now introduce grafts that shadow other grafts.

Browse Source 
Partly fixes <http://bugs.gnu.org/24418>.

* guix/grafts.scm (cumulative-grafts)[graft-origin?]: New procedure.
[dependency-grafts]: Use it in new 'if' around recursive call.
* tests/grafts.scm ("graft-derivation, grafts are not shadowed"): New test.
This commit is contained in:
Ludovic Courtès 2016-10-14 18:56:48 +02:00
parent d0025d0144
commit b013c33f6f
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 82 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
guix/grafts.scm
View File

@ -227,13 +227,29 @@ resulting list of grafts.
This is a monadic procedure in %STATE-MONAD where the state is a vhash mapping
derivations to the corresponding set of grafts."
(define (graft-origin? drv graft)
;; Return true if DRV corresponds to the origin of GRAFT.
(match graft
(($ <graft> (? derivation? origin) output)
(match (assoc-ref (derivation->output-paths drv) output)
((? string? result)
(string=? result
(derivation->output-path origin output)))
(_
#f)))
(_
#f)))
(define (dependency-grafts item)
(let-values (((drv output) (item->deriver store item)))
(if drv
(cumulative-grafts store drv grafts references
#:outputs (list output)
#:guile guile
#:system system)
;; If GRAFTS already contains a graft from DRV, do not override it.
(if (find (cut graft-origin? drv <>) grafts)
(state-return grafts)
(cumulative-grafts store drv grafts references
#:outputs (list output)
#:guile guile
#:system system))
(state-return grafts))))
(define (return/cache cache value)

62
tests/grafts.scm
View File

@ -218,4 +218,66 @@
(let ((out (derivation->output-path grafted)))
(file-is-directory? (string-append out "/" repl))))))
(test-assert "graft-derivation, grafts are not shadowed"
;; We build a DAG as below, where dotted arrows represent replacements and
;; solid arrows represent dependencies:
;;
;; P1 ·············> P1R
;; |\__________________.
;; v v
;; P2 ·············> P2R
;; |
;; v
;; P3
;;
;; We want to make sure that the two grafts we want to apply to P3 are
;; honored and not shadowed by other computed grafts.
(let* ((p1 (build-expression->derivation
%store "p1"
'(mkdir (assoc-ref %outputs "out"))))
(p1r (build-expression->derivation
%store "P1"
'(let ((out (assoc-ref %outputs "out")))
(mkdir out)
(call-with-output-file (string-append out "/replacement")
(const #t)))))
(p2 (build-expression->derivation
%store "p2"
`(let ((out (assoc-ref %outputs "out")))
(mkdir out)
(chdir out)
(symlink (assoc-ref %build-inputs "p1") "p1"))
#:inputs `(("p1" ,p1))))
(p2r (build-expression->derivation
%store "P2"
`(let ((out (assoc-ref %outputs "out")))
(mkdir out)
(chdir out)
(symlink (assoc-ref %build-inputs "p1") "p1")
(call-with-output-file (string-append out "/replacement")
(const #t)))
#:inputs `(("p1" ,p1))))
(p3 (build-expression->derivation
%store "p3"
`(let ((out (assoc-ref %outputs "out")))
(mkdir out)
(chdir out)
(symlink (assoc-ref %build-inputs "p2") "p2"))
#:inputs `(("p2" ,p2))))
(p1g (graft
(origin p1)
(replacement p1r)))
(p2g (graft
(origin p2)
(replacement (graft-derivation %store p2r (list p1g)))))
(p3d (graft-derivation %store p3 (list p1g p2g))))
(and (build-derivations %store (list p3d))
(let ((out (derivation->output-path (pk p3d))))
;; Make sure OUT refers to the replacement of P2, which in turn
;; refers to the replacement of P1, as specified by P1G and P2G.
;; It used to be the case that P2G would be shadowed by a simple
;; P2->P2R graft, which is not what we want.
(and (file-exists? (string-append out "/p2/replacement"))
(file-exists? (string-append out "/p2/p1/replacement")))))))
(test-end)