Browse Source
* guix/derivations.scm (<graft>, graft-derivation, %graft?)
(set-grafting): Move to...
* guix/grafts.scm: ... here. New file.
* guix/gexp.scm, guix/packages.scm, tests/packages.scm,
guix/scripts/build.scm: Use it.
* Makefile.am (MODULES): Add it.
(SCM_TESTS): Add tests/grafts.scm.
* tests/derivations.scm ("graft-derivation"): Move to...
* tests/grafts.scm: ... here. New file.
wip-mediagoblin
Ludovic Courtès
7 years ago
9 changed files with 217 additions and 135 deletions
@ -0,0 +1,127 @@ |
|||
;;; GNU Guix --- Functional package management for GNU |
|||
;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> |
|||
;;; |
|||
;;; This file is part of GNU Guix. |
|||
;;; |
|||
;;; GNU Guix is free software; you can redistribute it and/or modify it |
|||
;;; under the terms of the GNU General Public License as published by |
|||
;;; the Free Software Foundation; either version 3 of the License, or (at |
|||
;;; your option) any later version. |
|||
;;; |
|||
;;; GNU Guix is distributed in the hope that it will be useful, but |
|||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
;;; GNU General Public License for more details. |
|||
;;; |
|||
;;; You should have received a copy of the GNU General Public License |
|||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
|||
|
|||
(define-module (guix grafts) |
|||
#:use-module (guix records) |
|||
#:use-module (guix derivations) |
|||
#:use-module ((guix utils) #:select (%current-system)) |
|||
#:use-module (srfi srfi-1) |
|||
#:use-module (srfi srfi-26) |
|||
#:use-module (ice-9 match) |
|||
#:export (graft? |
|||
graft |
|||
graft-origin |
|||
graft-replacement |
|||
graft-origin-output |
|||
graft-replacement-output |
|||
|
|||
graft-derivation |
|||
|
|||
%graft? |
|||
set-grafting)) |
|||
|
|||
(define-record-type* <graft> graft make-graft |
|||
graft? |
|||
(origin graft-origin) ;derivation | store item |
|||
(origin-output graft-origin-output ;string | #f |
|||
(default "out")) |
|||
(replacement graft-replacement) ;derivation | store item |
|||
(replacement-output graft-replacement-output ;string | #f |
|||
(default "out"))) |
|||
|
|||
(define* (graft-derivation store name drv grafts |
|||
#:key (guile (%guile-for-build)) |
|||
(system (%current-system))) |
|||
"Return a derivation called NAME, based on DRV but with all the GRAFTS |
|||
applied." |
|||
;; XXX: Someday rewrite using gexps. |
|||
(define mapping |
|||
;; List of store item pairs. |
|||
(map (match-lambda |
|||
(($ <graft> source source-output target target-output) |
|||
(cons (if (derivation? source) |
|||
(derivation->output-path source source-output) |
|||
source) |
|||
(if (derivation? target) |
|||
(derivation->output-path target target-output) |
|||
target)))) |
|||
grafts)) |
|||
|
|||
(define outputs |
|||
(match (derivation-outputs drv) |
|||
(((names . outputs) ...) |
|||
(map derivation-output-path outputs)))) |
|||
|
|||
(define output-names |
|||
(match (derivation-outputs drv) |
|||
(((names . outputs) ...) |
|||
names))) |
|||
|
|||
(define build |
|||
`(begin |
|||
(use-modules (guix build graft) |
|||
(guix build utils) |
|||
(ice-9 match)) |
|||
|
|||
(let ((mapping ',mapping)) |
|||
(for-each (lambda (input output) |
|||
(format #t "grafting '~a' -> '~a'...~%" input output) |
|||
(force-output) |
|||
(rewrite-directory input output |
|||
`((,input . ,output) |
|||
,@mapping))) |
|||
',outputs |
|||
(match %outputs |
|||
(((names . files) ...) |
|||
files)))))) |
|||
|
|||
(define add-label |
|||
(cut cons "x" <>)) |
|||
|
|||
(match grafts |
|||
((($ <graft> sources source-outputs targets target-outputs) ...) |
|||
(let ((sources (zip sources source-outputs)) |
|||
(targets (zip targets target-outputs))) |
|||
(build-expression->derivation store name build |
|||
#:system system |
|||
#:guile-for-build guile |
|||
#:modules '((guix build graft) |
|||
(guix build utils)) |
|||
#:inputs `(,@(map (lambda (out) |
|||
`("x" ,drv ,out)) |
|||
output-names) |
|||
,@(append (map add-label sources) |
|||
(map add-label targets))) |
|||
#:outputs output-names |
|||
#:local-build? #t))))) |
|||
|
|||
|
|||
;; The following might feel more at home in (guix packages) but since (guix |
|||
;; gexp), which is a lower level, needs them, we put them here. |
|||
|
|||
(define %graft? |
|||
;; Whether to honor package grafts by default. |
|||
(make-parameter #t)) |
|||
|
|||
(define (set-grafting enable?) |
|||
"This monadic procedure enables grafting when ENABLE? is true, and disables |
|||
it otherwise. It returns the previous setting." |
|||
(lambda (store) |
|||
(values (%graft? enable?) store))) |
|||
|
|||
;;; grafts.scm ends here |
|||
@ -0,0 +1,81 @@ |
|||
;;; GNU Guix --- Functional package management for GNU |
|||
;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> |
|||
;;; |
|||
;;; This file is part of GNU Guix. |
|||
;;; |
|||
;;; GNU Guix is free software; you can redistribute it and/or modify it |
|||
;;; under the terms of the GNU General Public License as published by |
|||
;;; the Free Software Foundation; either version 3 of the License, or (at |
|||
;;; your option) any later version. |
|||
;;; |
|||
;;; GNU Guix is distributed in the hope that it will be useful, but |
|||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
;;; GNU General Public License for more details. |
|||
;;; |
|||
;;; You should have received a copy of the GNU General Public License |
|||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
|||
|
|||
(define-module (test-grafts) |
|||
#:use-module (guix derivations) |
|||
#:use-module (guix store) |
|||
#:use-module (guix utils) |
|||
#:use-module (guix grafts) |
|||
#:use-module (guix tests) |
|||
#:use-module ((gnu packages) #:select (search-bootstrap-binary)) |
|||
#:use-module (srfi srfi-64) |
|||
#:use-module (rnrs io ports)) |
|||
|
|||
(define %store |
|||
(open-connection-for-tests)) |
|||
|
|||
(define (bootstrap-binary name) |
|||
(let ((bin (search-bootstrap-binary name (%current-system)))) |
|||
(and %store |
|||
(add-to-store %store name #t "sha256" bin)))) |
|||
|
|||
(define %bash |
|||
(bootstrap-binary "bash")) |
|||
(define %mkdir |
|||
(bootstrap-binary "mkdir")) |
|||
|
|||
|
|||
(test-begin "grafts") |
|||
|
|||
(test-assert "graft-derivation" |
|||
(let* ((build `(begin |
|||
(mkdir %output) |
|||
(chdir %output) |
|||
(symlink %output "self") |
|||
(call-with-output-file "text" |
|||
(lambda (output) |
|||
(format output "foo/~a/bar" ,%mkdir))) |
|||
(symlink ,%bash "sh"))) |
|||
(orig (build-expression->derivation %store "graft" build |
|||
#:inputs `(("a" ,%bash) |
|||
("b" ,%mkdir)))) |
|||
(one (add-text-to-store %store "bash" "fake bash")) |
|||
(two (build-expression->derivation %store "mkdir" |
|||
'(call-with-output-file %output |
|||
(lambda (port) |
|||
(display "fake mkdir" port))))) |
|||
(graft (graft-derivation %store "graft" orig |
|||
(list (graft |
|||
(origin %bash) |
|||
(replacement one)) |
|||
(graft |
|||
(origin %mkdir) |
|||
(replacement two)))))) |
|||
(and (build-derivations %store (list graft)) |
|||
(let ((two (derivation->output-path two)) |
|||
(graft (derivation->output-path graft))) |
|||
(and (string=? (format #f "foo/~a/bar" two) |
|||
(call-with-input-file (string-append graft "/text") |
|||
get-string-all)) |
|||
(string=? (readlink (string-append graft "/sh")) one) |
|||
(string=? (readlink (string-append graft "/self")) graft)))))) |
|||
|
|||
(test-end) |
|||
|
|||
|
|||
(exit (= (test-runner-fail-count (test-runner-current)) 0)) |
|||
Loading…
Reference in new issue