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

derivations: Move grafts to (guix grafts).

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.
This commit is contained in:
Ludovic Courtès 2016-02-22 16:29:44 +01:00
parent 3297deedd1
commit 7adf9b8469
9 changed files with 217 additions and 135 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Makefile.am
View file

@ -49,6 +49,7 @@ MODULES = \
guix/serialization.scm \
guix/nar.scm \
guix/derivations.scm \
guix/grafts.scm \
guix/gnu-maintenance.scm \
guix/upstream.scm \
guix/licenses.scm \
@ -220,6 +221,7 @@ SCM_TESTS = \
tests/substitute.scm \
tests/builders.scm \
tests/derivations.scm \
tests/grafts.scm \
tests/ui.scm \
tests/records.scm \
tests/utils.scm \

98
guix/derivations.scm
View file

@ -85,21 +85,11 @@ (define-module (guix derivations)
derivation-path->output-paths
derivation
graft
graft?
graft-origin
graft-replacement
graft-origin-output
graft-replacement-output
graft-derivation
map-derivation
build-derivations
built-derivations
%graft?
set-grafting
build-expression->derivation)
@ -1111,81 +1101,6 @@ (define builder
#:guile-for-build guile
#:local-build? #t)))
(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)))))
(define* (build-expression->derivation store name exp ;deprecated
#:key
(system (%current-system))
@ -1353,16 +1268,3 @@ (define %build-inputs
(define built-derivations
(store-lift build-derivations))
;; 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)))

3
guix/gexp.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -20,6 +20,7 @@ (define-module (guix gexp)
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix derivations)
#:use-module (guix grafts)
#:use-module (guix utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)

127
guix/grafts.scm Normal file
View file

@ -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

3
guix/packages.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014, 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
;;;
@ -25,6 +25,7 @@ (define-module (guix packages)
#:use-module (guix monads)
#:use-module (guix gexp)
#:use-module (guix base32)
#:use-module (guix grafts)
#:use-module (guix derivations)
#:use-module (guix build-system)
#:use-module (guix search-paths)

1
guix/scripts/build.scm
View file

@ -23,6 +23,7 @@ (define-module (guix scripts build)
#:use-module (guix store)
#:use-module (guix derivations)
#:use-module (guix packages)
#:use-module (guix grafts)
#:use-module (guix utils)
#:use-module (guix monads)
#:use-module (guix gexp)

34
tests/derivations.scm
View file

@ -929,40 +929,6 @@ (define (deps path . deps)
((p2 . _)
(string<? p1 p2)))))))))))))
(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-equal "map-derivation"
"hello"
(let* ((joke (package-derivation %store guile-1.8))

81
tests/grafts.scm Normal file
View file

@ -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))

3
tests/packages.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -29,6 +29,7 @@ (define-module (test-packages)
#:use-module (guix hash)
#:use-module (guix derivations)
#:use-module (guix packages)
#:use-module (guix grafts)
#:use-module (guix search-paths)
#:use-module (guix build-system)
#:use-module (guix build-system trivial)